[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
master 88e1f8b020 1/3: Merge branch 'scratch/correct-warning-pos'
|
From: |
Alan Mackenzie |
|
Subject: |
master 88e1f8b020 1/3: Merge branch 'scratch/correct-warning-pos' |
|
Date: |
Sat, 22 Jan 2022 13:05:55 -0500 (EST) |
branch: master
commit 88e1f8b02086aaf652e3058b36b7612c073c04b3
Merge: 1edde2fc7a 14d64a8adc
Author: Alan Mackenzie <acm@muc.de>
Commit: Alan Mackenzie <acm@muc.de>
Merge branch 'scratch/correct-warning-pos'
---
doc/lispref/elisp.texi | 3 +
doc/lispref/streams.texi | 10 +
doc/lispref/symbols.texi | 82 +++++-
lisp/cedet/semantic/fw.el | 32 ++-
lisp/emacs-lisp/bindat.el | 1 +
lisp/emacs-lisp/byte-opt.el | 38 +--
lisp/emacs-lisp/byte-run.el | 85 +++++-
lisp/emacs-lisp/bytecomp.el | 613 ++++++++++++++++++++++--------------------
lisp/emacs-lisp/cconv.el | 41 +--
lisp/emacs-lisp/cl-generic.el | 4 +-
lisp/emacs-lisp/cl-macs.el | 12 +-
lisp/emacs-lisp/comp.el | 19 +-
lisp/emacs-lisp/easy-mmode.el | 1 +
lisp/emacs-lisp/eieio-core.el | 5 +
lisp/emacs-lisp/eieio.el | 17 +-
lisp/emacs-lisp/gv.el | 5 +-
lisp/emacs-lisp/macroexp.el | 330 ++++++++++++-----------
lisp/emacs-lisp/pcase.el | 2 +
lisp/help.el | 2 +-
lisp/keymap.el | 11 +-
src/.gdbinit | 12 +
src/alloc.c | 40 ++-
src/comp.c | 301 ++++++++++++++++++++-
src/data.c | 109 +++++++-
src/eval.c | 7 +-
src/fns.c | 12 +-
src/keyboard.c | 2 +
src/lisp.h | 216 ++++++++++-----
src/lread.c | 139 ++++++----
src/print.c | 33 ++-
30 files changed, 1521 insertions(+), 663 deletions(-)
diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi
index 1f339ef799..426bb6d017 100644
--- a/doc/lispref/elisp.texi
+++ b/doc/lispref/elisp.texi
@@ -448,6 +448,9 @@ Symbols
* Creating Symbols:: How symbols are kept unique.
* Symbol Properties:: Each symbol has a property list
for recording miscellaneous information.
+* Shorthands:: Properly organize your symbol names but
+ type less of them.
+* Symbols with Position:: Symbol variants containing integer positions
Symbol Properties
diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi
index 784adb9bd5..18ca9f06b8 100644
--- a/doc/lispref/streams.texi
+++ b/doc/lispref/streams.texi
@@ -326,6 +326,16 @@ For example:
@end group
@end example
@end defun
+@end defun
+
+@defun read-positioning-symbols &optional stream
+This function reads one textual expression from @var{stream}, like
+@code{read} does, but additionally positions the read symbols to the
+positions in @var{stream} where they occurred. Only the symbol
+@code{nil} is not positioned, this for efficiency reasons.
+@xref{Symbols with Position}. This function is used by the byte
+compiler.
+@end defun
@defvar standard-input
This variable holds the default input stream---the stream that
diff --git a/doc/lispref/symbols.texi b/doc/lispref/symbols.texi
index a951e9be8a..f3a9e586e3 100644
--- a/doc/lispref/symbols.texi
+++ b/doc/lispref/symbols.texi
@@ -23,15 +23,15 @@ otherwise.
@end defun
@menu
-* Symbol Components:: Symbols have names, values, function definitions
+* Symbol Components:: Symbols have names, values, function
definitions
and property lists.
-* Definitions:: A definition says how a symbol will be used.
-* Creating Symbols:: How symbols are kept unique.
-* Symbol Properties:: Each symbol has a property list
+* Definitions:: A definition says how a symbol will be used.
+* Creating Symbols:: How symbols are kept unique.
+* Symbol Properties:: Each symbol has a property list
for recording miscellaneous information.
-* Shorthands:: Properly organize your symbol names but
+* Shorthands:: Properly organize your symbol names but
type less of them.
-
+* Symbols with Position:: Symbol variants containing integer positions
@end menu
@node Symbol Components
@@ -432,8 +432,8 @@ symbol's property list cell (@pxref{Symbol Components}), in
the form
of a property list (@pxref{Property Lists}).
@menu
-* Symbol Plists:: Accessing symbol properties.
-* Standard Properties:: Standard meanings of symbol properties.
+* Symbol Plists:: Accessing symbol properties.
+* Standard Properties:: Standard meanings of symbol properties.
@end menu
@node Symbol Plists
@@ -751,3 +751,69 @@ those names.
@item
Symbol forms whose names start with @samp{#_} are not transformed.
@end itemize
+
+@node Symbols with Position
+@section Symbols with Position
+@cindex symbols with position
+
+A @dfn{symbol with position} is a symbol, the @dfn{bare symbol},
+together with an unsigned integer called the @dfn{position}. These
+objects are intended for use by the byte compiler, which records in
+them the position of each symbol occurrence and uses those positions
+in warning and error messages.
+
+The printed representation of a symbol with position uses the hash
+notation outlined in @ref{Printed Representation}. It looks like
+@samp{#<symbol foo at 12345>}. It has no read syntax. You can cause
+just the bare symbol to be printed by binding the variable
+@code{print-symbols-bare} to non-@code{nil} around the print
+operation. The byte compiler does this before writing its output to
+the compiled Lisp file.
+
+For most purposes, when the flag variable
+@code{symbols-with-pos-enabled} is non-@code{nil}, symbols with
+positions behave just as bare symbols do. For example, @samp{(eq
+#<symbol foo at 12345> foo)} has a value @code{t} when that variable
+is set (but nil when it isn't set). Most of the time in Emacs this
+variable is @code{nil}, but the byte compiler binds it to @code{t}
+when it runs.
+
+Typically, symbols with position are created by the byte compiler
+calling the reader function @code{read-positioning-symbols}
+(@pxref{Input Functions}). One can also be created with the function
+@code{position-symbol}.
+
+@defvar symbols-with-pos-enabled
+When this variable is non-@code{nil}, symbols with position behave
+like the contained bare symbol. Emacs runs a little more slowly in
+this case.
+@end defvar
+
+@defvar print-symbols-bare
+When bound to non-nil, the Lisp printer prints only the bare symbol of
+a symbol with position, ignoring the position.
+@end defvar
+
+@defun symbol-with-pos-p symbol.
+This function returns @code{t} if @var{symbol} is a symbol with
+position, @code{nil} otherwise.
+@end defun
+
+@defun bare-symbol symbol
+This function returns the bare symbol contained in @var{symbol}, or
+@var{symbol} itself if it is already a bare symbol. For any other
+type of object, it throws an error.
+@end defun
+
+@defun symbol-with-pos-pos symbol
+This function returns the position, a number, from a symbol with
+position. For any other type of object, it throws an error.
+@end defun
+
+@defun position-symbol sym pos
+Make a new symbol with position. @var{sym} is either a bare symbol or
+a symbol with position, and supplies the symbol part of the new
+object. @var{pos} is either an integer which becomes the number part
+of the new object, or a symbol with position whose position is used.
+Emacs throws an error if either argument is invalid.
+@end defun
diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el
index fd61751cb5..b7c3461a4d 100644
--- a/lisp/cedet/semantic/fw.el
+++ b/lisp/cedet/semantic/fw.el
@@ -191,12 +191,20 @@ will throw a warning when it encounters this symbol."
(not (string-match "cedet" (macroexp-file-name)))
)
(make-obsolete-overload oldfnalias newfn when)
- (byte-compile-warn
- "%s: `%s' obsoletes overload `%s'"
- (macroexp-file-name)
- newfn
- (with-suppressed-warnings ((obsolete
semantic-overload-symbol-from-function))
- (semantic-overload-symbol-from-function oldfnalias)))))
+ (if (fboundp 'byte-compile-warn-x)
+ (byte-compile-warn-x
+ newfn
+ "%s: `%s' obsoletes overload `%s'"
+ (macroexp-file-name)
+ newfn
+ (with-suppressed-warnings ((obsolete
semantic-overload-symbol-from-function))
+ (semantic-overload-symbol-from-function oldfnalias)))
+ (byte-compile-warn
+ "%s: `%s' obsoletes overload `%s'"
+ (macroexp-file-name)
+ newfn
+ (with-suppressed-warnings ((obsolete
semantic-overload-symbol-from-function))
+ (semantic-overload-symbol-from-function oldfnalias))))))
(defun semantic-varalias-obsolete (oldvaralias newvar when)
"Make OLDVARALIAS an alias for variable NEWVAR.
@@ -209,10 +217,14 @@ will throw a warning when it encounters this symbol."
(error
;; Only throw this warning when byte compiling things.
(when (macroexp-compiling-p)
- (byte-compile-warn
- "variable `%s' obsoletes, but isn't alias of `%s'"
- newvar oldvaralias)
- ))))
+ (if (fboundp 'byte-compile-warn-x)
+ (byte-compile-warn-x
+ newvar
+ "variable `%s' obsoletes, but isn't alias of `%s'"
+ newvar oldvaralias)
+ (byte-compile-warn
+ "variable `%s' obsoletes, but isn't alias of `%s'"
+ newvar oldvaralias))))))
;;; Help debugging
;;
diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el
index c6d64975ec..04c5b9f080 100644
--- a/lisp/emacs-lisp/bindat.el
+++ b/lisp/emacs-lisp/bindat.el
@@ -804,6 +804,7 @@ is the name of a variable that will hold the value we need
to pack.")
(if (or (eq label '_) (not (assq label labels)))
code
(macroexp-warn-and-return
+ code
(format "Duplicate label: %S" label)
code))))
(`(,_ ,val)
diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el
index bd57e2b203..a0c6dd99a9 100644
--- a/lisp/emacs-lisp/byte-opt.el
+++ b/lisp/emacs-lisp/byte-opt.el
@@ -264,8 +264,9 @@ Earlier variables shadow later ones with the same name.")
(cdr (assq name byte-compile-function-environment)))))
(pcase fn
('nil
- (byte-compile-warn "attempt to inline `%s' before it was defined"
- name)
+ (byte-compile-warn-x name
+ "attempt to inline `%s' before it was defined"
+ name)
form)
(`(autoload . ,_)
(error "File `%s' didn't define `%s'" (nth 1 fn) name))
@@ -421,8 +422,8 @@ for speeding up processing.")
(t form)))
(`(quote . ,v)
(if (or (not v) (cdr v))
- (byte-compile-warn "malformed quote form: `%s'"
- (prin1-to-string form)))
+ (byte-compile-warn-x form "malformed quote form: `%s'"
+ form))
;; Map (quote nil) to nil to simplify optimizer logic.
;; Map quoted constants to nil if for-effect (just because).
(and (car v)
@@ -440,8 +441,9 @@ for speeding up processing.")
(cons
(byte-optimize-form (car clause) nil)
(byte-optimize-body (cdr clause) for-effect))
- (byte-compile-warn "malformed cond form: `%s'"
- (prin1-to-string clause))
+ (byte-compile-warn-x
+ clause "malformed cond form: `%s'"
+ clause)
clause))
clauses)))
(`(progn . ,exps)
@@ -517,8 +519,7 @@ for speeding up processing.")
`(while ,condition . ,body)))
(`(interactive . ,_)
- (byte-compile-warn "misplaced interactive spec: `%s'"
- (prin1-to-string form))
+ (byte-compile-warn-x form "misplaced interactive spec: `%s'" form)
nil)
(`(function . ,_)
@@ -586,7 +587,7 @@ for speeding up processing.")
(while args
(unless (and (consp args)
(symbolp (car args)) (consp (cdr args)))
- (byte-compile-warn "malformed setq form: %S" form))
+ (byte-compile-warn-x form "malformed setq form: %S" form))
(let* ((var (car args))
(expr (cadr args))
(lexvar (assq var byte-optimize--lexvars))
@@ -619,8 +620,7 @@ for speeding up processing.")
(cons fn (mapcar #'byte-optimize-form exps)))
(`(,(pred (not symbolp)) . ,_)
- (byte-compile-warn "`%s' is a malformed function"
- (prin1-to-string fn))
+ (byte-compile-warn-x fn "`%s' is a malformed function" fn)
form)
((guard (when for-effect
@@ -628,8 +628,10 @@ for speeding up processing.")
(or byte-compile-delete-errors
(eq tmp 'error-free)
(progn
- (byte-compile-warn "value returned from %s is unused"
- (prin1-to-string form))
+ (byte-compile-warn-x
+ form
+ "value returned from %s is unused"
+ form)
nil)))))
(byte-compile-log " %s called for effect; deleted" fn)
;; appending a nil here might not be necessary, but it can't hurt.
@@ -825,7 +827,8 @@ for speeding up processing.")
(if (symbolp binding)
binding
(when (or (atom binding) (cddr binding))
- (byte-compile-warn "malformed let binding: `%S'" binding))
+ (byte-compile-warn-x
+ binding "malformed let binding: `%S'" binding))
(list (car binding)
(byte-optimize-form (nth 1 binding) nil))))
(car form))
@@ -1308,7 +1311,7 @@ See Info node `(elisp) Integer Basics'."
(defun byte-optimize-while (form)
(when (< (length form) 2)
- (byte-compile-warn "too few arguments for `while'"))
+ (byte-compile-warn-x form "too few arguments for `while'"))
(if (nth 1 form)
form))
@@ -1346,9 +1349,10 @@ See Info node `(elisp) Integer Basics'."
(let ((butlast (nreverse (cdr (reverse (cdr (cdr form)))))))
(nconc (list 'funcall fn) butlast
(mapcar (lambda (x) (list 'quote x)) (nth 1 last))))
- (byte-compile-warn
+ (byte-compile-warn-x
+ last
"last arg to apply can't be a literal atom: `%s'"
- (prin1-to-string last))
+ last)
nil))
form))))
diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 47f331fd9d..fedc10cea4 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -30,6 +30,83 @@
;;; Code:
+(defvar byte-run--ssp-seen nil
+ "Which conses/vectors/records have been processed in strip-symbol-positions?
+The value is a hash table, the key being the old element and the value being
+the corresponding new element of the same type.
+
+The purpose of this is to detect circular structures.")
+
+(defalias 'byte-run--circular-list-p
+ #'(lambda (l)
+ "Return non-nil when the list L is a circular list.
+Note that this algorithm doesn't check any circularity in the
+CARs of list elements."
+ (let ((hare l)
+ (tortoise l))
+ (condition-case err
+ (progn
+ (while (progn
+ (setq hare (cdr (cdr hare))
+ tortoise (cdr tortoise))
+ (not (or (eq tortoise hare)
+ (null hare)))))
+ (eq tortoise hare))
+ (wrong-type-argument nil)
+ (error (signal (car err) (cdr err)))))))
+
+(defalias 'byte-run--strip-s-p-1
+ #'(lambda (arg)
+ "Strip all positions from symbols in ARG, modifying ARG.
+Return the modified ARG."
+ (cond
+ ((symbol-with-pos-p arg)
+ (bare-symbol arg))
+
+ ((consp arg)
+ (let* ((round (byte-run--circular-list-p arg))
+ (hash (and round (gethash arg byte-run--ssp-seen))))
+ (or hash
+ (let ((a arg) new)
+ (while
+ (progn
+ (when round
+ (puthash a new byte-run--ssp-seen))
+ (setq new (byte-run--strip-s-p-1 (car a)))
+ (when (not (eq new (car a))) ; For read-only things.
+ (setcar a new))
+ (and (consp (cdr a))
+ (not
+ (setq hash
+ (and round
+ (gethash (cdr a)
byte-run--ssp-seen))))))
+ (setq a (cdr a)))
+ (setq new (byte-run--strip-s-p-1 (cdr a)))
+ (when (not (eq new (cdr a)))
+ (setcdr a (or hash new)))
+ arg))))
+
+ ((or (vectorp arg) (recordp arg))
+ (let ((hash (gethash arg byte-run--ssp-seen)))
+ (or hash
+ (let* ((len (length arg))
+ (i 0)
+ new)
+ (puthash arg arg byte-run--ssp-seen)
+ (while (< i len)
+ (setq new (byte-run--strip-s-p-1 (aref arg i)))
+ (when (not (eq new (aref arg i)))
+ (aset arg i new))
+ (setq i (1+ i)))
+ arg))))
+
+ (t arg))))
+
+(defalias 'byte-run-strip-symbol-positions
+ #'(lambda (arg)
+ (setq byte-run--ssp-seen (make-hash-table :test 'eq))
+ (byte-run--strip-s-p-1 arg)))
+
(defalias 'function-put
;; We don't want people to just use `put' because we can't conveniently
;; hook into `put' to remap old properties to new ones. But for now, there's
@@ -38,7 +115,9 @@
"Set FUNCTION's property PROP to VALUE.
The namespace for PROP is shared with symbols.
So far, FUNCTION can only be a symbol, not a lambda expression."
- (put function prop value)))
+ (put (bare-symbol function)
+ (byte-run-strip-symbol-positions prop)
+ (byte-run-strip-symbol-positions value))))
(function-put 'defmacro 'doc-string-elt 3)
(function-put 'defmacro 'lisp-indent-function 2)
@@ -254,7 +333,8 @@ The return value is undefined.
#'(lambda (x)
(let ((f (cdr (assq (car x) macro-declarations-alist))))
(if f (apply (car f) name arglist (cdr x))
- (macroexp-warn-and-return
+ (macroexp-warn-and-return
+ (car x)
(format-message
"Unknown macro property %S in %S"
(car x) name)
@@ -328,6 +408,7 @@ The return value is undefined.
nil)
(t
(macroexp-warn-and-return
+ (car x)
(format-message "Unknown defun property `%S' in %S"
(car x) name)
nil)))))
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 436783819f..903dd50e34 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -468,7 +468,8 @@ Return the compile-time value of FORM."
;; 3.2.3.1, "Processing of Top Level Forms". The semantics are very
;; subtle: see test/lisp/emacs-lisp/bytecomp-tests.el for interesting
;; cases.
- (setf form (macroexp-macroexpand form byte-compile-macro-environment))
+ (let ((print-symbols-bare t))
+ (setf form (macroexp-macroexpand form byte-compile-macro-environment)))
(if (eq (car-safe form) 'progn)
(cons 'progn
(mapcar (lambda (subform)
@@ -499,8 +500,8 @@ Return the compile-time value of FORM."
byte-compile-new-defuns))
(setf result
(byte-compile-eval
- (byte-compile-top-level
- (byte-compile-preprocess form)))))))
+ (byte-compile-top-level
+ (byte-compile-preprocess
form)))))))
(list 'quote result))))
(eval-and-compile . ,(lambda (&rest body)
(byte-compile-recurse-toplevel
@@ -509,10 +510,11 @@ Return the compile-time value of FORM."
;; Don't compile here, since we don't know
;; whether to compile as byte-compile-form
;; or byte-compile-file-form.
- (let ((expanded
- (macroexpand--all-toplevel
- form
- macroexpand-all-environment)))
+ (let* ((print-symbols-bare t)
+ (expanded
+ (macroexpand--all-toplevel
+ form
+ macroexpand-all-environment)))
(eval expanded lexical-binding)
expanded)))))
(with-suppressed-warnings
@@ -1147,11 +1149,6 @@ message buffer `default-directory'."
(t
(insert (format "%s\n" string)))))))
-(defvar byte-compile-read-position nil
- "Character position we began the last `read' from.")
-(defvar byte-compile-last-position nil
- "Last known character position in the input.")
-
;; copied from gnus-util.el
(defsubst byte-compile-delete-first (elt list)
(if (eq (car list) elt)
@@ -1164,43 +1161,6 @@ message buffer `default-directory'."
(setcdr list (cddr list)))
total)))
-;; The purpose of `byte-compile-set-symbol-position' is to attempt to
-;; set `byte-compile-last-position' to the "current position" in the
-;; raw source code. This is used for warning and error messages.
-;;
-;; The function should be called for most occurrences of symbols in
-;; the forms being compiled, strictly in the order they occur in the
-;; source code. It should never be called twice for any single
-;; occurrence, and should not be called for symbols generated by the
-;; byte compiler itself.
-;;
-;; The function works by scanning the elements in the alist
-;; `read-symbol-positions-list' for the next match for the symbol
-;; after the current value of `byte-compile-last-position', setting
-;; that variable to the match's character position, then deleting the
-;; matching element from the list. Thus the new value for
-;; `byte-compile-last-position' is later than the old value unless,
-;; perhaps, ALLOW-PREVIOUS is non-nil.
-;;
-;; So your're probably asking yourself: Isn't this function a gross
-;; hack? And the answer, of course, would be yes.
-(defun byte-compile-set-symbol-position (sym &optional allow-previous)
- (when byte-compile-read-position
- (let ((last byte-compile-last-position)
- entry)
- (while (progn
- (setq entry (assq sym read-symbol-positions-list))
- (when entry
- (setq byte-compile-last-position
- (+ byte-compile-read-position (cdr entry))
- read-symbol-positions-list
- (byte-compile-delete-first
- entry read-symbol-positions-list)))
- (and entry
- (or (and allow-previous
- (not (= last byte-compile-last-position)))
- (> last byte-compile-last-position))))))))
-
(defvar byte-compile-last-warned-form nil)
(defvar byte-compile-last-logged-file nil)
(defvar byte-compile-root-dir nil
@@ -1213,6 +1173,41 @@ message buffer `default-directory'."
(f2 (file-relative-name file dir)))
(if (< (length f2) (length f1)) f2 f1)))
+(defun byte-compile--first-symbol (form)
+ "Return the \"first\" symbol found in form, or 0 if there is none.
+Here, \"first\" is by a depth first search."
+ (let (sym)
+ (cond
+ ((symbolp form) form)
+ ((consp form)
+ (or (and (symbolp (setq sym (byte-compile--first-symbol (car form))))
+ sym)
+ (and (symbolp (setq sym (byte-compile--first-symbol (cdr form))))
+ sym)
+ 0))
+ ((and (vectorp form)
+ (> (length form) 0))
+ (let ((i 0)
+ (len (length form))
+ elt)
+ (catch 'sym
+ (while (< i len)
+ (when (symbolp
+ (setq elt (byte-compile--first-symbol (aref form i))))
+ (throw 'sym elt))
+ (setq i (1+ i)))
+ 0)))
+ (t 0))))
+
+(defun byte-compile--warning-source-offset ()
+ "Return a source offset from `byte-compile-form-stack'.
+Return nil if such is not found."
+ (catch 'offset
+ (dolist (form byte-compile-form-stack)
+ (let ((s (byte-compile--first-symbol form)))
+ (if (symbol-with-pos-p s)
+ (throw 'offset (symbol-with-pos-pos s)))))))
+
;; This is used as warning-prefix for the compiler.
;; It is always called with the warnings buffer current.
(defun byte-compile-warning-prefix (level entry)
@@ -1230,16 +1225,16 @@ message buffer `default-directory'."
(format "%s:" (byte-compile-abbreviate-file
load-file-name dir)))
(t "")))
+ (offset (byte-compile--warning-source-offset))
(pos (if (and byte-compile-current-file
- (integerp byte-compile-read-position))
+ (or offset (not symbols-with-pos-enabled)))
(with-current-buffer byte-compile-current-buffer
- (format "%d:%d:"
- (save-excursion
- (goto-char byte-compile-last-position)
- (1+ (count-lines (point-min) (point-at-bol))))
- (save-excursion
- (goto-char byte-compile-last-position)
- (1+ (current-column)))))
+ (let (new-l new-c)
+ (save-excursion
+ (goto-char offset)
+ (setq new-l (1+ (count-lines (point-min)
(point-at-bol)))
+ new-c (1+ (current-column)))
+ (format "%d:%d:" new-l new-c))))
""))
(form (if (eq byte-compile-current-form :end) "end of data"
(or byte-compile-current-form "toplevel form"))))
@@ -1314,20 +1309,21 @@ Called with arguments (STRING POSITION FILL LEVEL).
STRING is a
message describing the problem. POSITION is a buffer position
where the problem was detected. FILL is a prefix as in
`warning-fill-prefix'. LEVEL is the level of the
-problem (`:warning' or `:error'). POSITION, FILL and LEVEL may be
-nil.")
+problem (`:warning' or `:error'). FILL and LEVEL may be nil.")
(defun byte-compile-log-warning (string &optional fill level)
"Log a byte-compilation warning.
STRING, FILL and LEVEL are as described in
`byte-compile-log-warning-function', which see."
(funcall byte-compile-log-warning-function
- string byte-compile-last-position
+ string
+ (or (byte-compile--warning-source-offset)
+ (point))
fill
level))
-(defun byte-compile--log-warning-for-byte-compile (string &optional
- _position
+(defun byte-compile--log-warning-for-byte-compile (string _position
+ &optional
fill
level)
"Log a message STRING in `byte-compile-log-buffer'.
@@ -1348,6 +1344,14 @@ function directly; use `byte-compile-warn' or
(error "%s" format) ; byte-compile-file catches and logs it
(byte-compile-log-warning format t :warning)))
+(defun byte-compile-warn-x (arg format &rest args)
+ "Issue a byte compiler warning.
+ARG is the source element (likely a symbol with position) central to
+ the warning, intended to supply source position information.
+FORMAT and ARGS are as in `byte-compile-warn'."
+ (let ((byte-compile-form-stack (cons arg byte-compile-form-stack)))
+ (apply #'byte-compile-warn format args)))
+
(defun byte-compile-warn-obsolete (symbol)
"Warn that SYMBOL (a variable or function) is obsolete."
(when (byte-compile-warning-enabled-p 'obsolete symbol)
@@ -1357,7 +1361,7 @@ function directly; use `byte-compile-warn' or
(or funcp (get symbol 'byte-obsolete-variable))
(if funcp "function" "variable"))))
(unless (and funcp (memq symbol byte-compile-not-obsolete-funcs))
- (byte-compile-warn "%s" msg)))))
+ (byte-compile-warn-x symbol "%s" msg)))))
(defun byte-compile-report-error (error-info &optional fill)
"Report Lisp error in compilation.
@@ -1460,7 +1464,6 @@ when printing the error message."
(t (format "%d-%d" (car signature) (cdr signature)))))
(defun byte-compile-function-warn (f nargs def)
- (byte-compile-set-symbol-position f)
(when (and (get f 'byte-obsolete-info)
(byte-compile-warning-enabled-p 'obsolete f))
(byte-compile-warn-obsolete f))
@@ -1477,12 +1480,16 @@ when printing the error message."
(if cons
(or (memq nargs (cddr cons))
(push nargs (cddr cons)))
- (push (list f byte-compile-last-position nargs)
+ (push (list f
+ (if (symbol-with-pos-p f)
+ (symbol-with-pos-pos f)
+ 1) ; Should never happen.
+ nargs)
byte-compile-unresolved-functions)))))
(defun byte-compile-emit-callargs-warn (name actual-args min-args max-args)
- (byte-compile-set-symbol-position name)
- (byte-compile-warn
+ (byte-compile-warn-x
+ name
"%s called with %d argument%s, but %s %s"
name actual-args
(if (= 1 actual-args) "" "s")
@@ -1548,7 +1555,7 @@ extra args."
n)))
(nargs (- (length form) 2)))
(unless (= nargs nfields)
- (byte-compile-warn
+ (byte-compile-warn-x (car form)
"`%s' called with %d args to fill %d format field(s)" (car form)
nargs nfields)))))
@@ -1562,7 +1569,7 @@ extra args."
(when (eq (car-safe name) 'quote)
(or (not (eq (car form) 'custom-declare-variable))
(plist-get keyword-args :type)
- (byte-compile-warn
+ (byte-compile-warn-x (cadr name)
"defcustom for `%s' fails to specify type" (cadr name)))
(if (and (memq (car form) '(custom-declare-face custom-declare-variable))
byte-compile-current-group)
@@ -1571,7 +1578,7 @@ extra args."
(or (and (eq (car form) 'custom-declare-group)
(equal name ''emacs))
(plist-get keyword-args :group)
- (byte-compile-warn
+ (byte-compile-warn-x (cadr name)
"%s for `%s' fails to specify containing group"
(cdr (assq (car form)
'((custom-declare-group . defgroup)
@@ -1590,7 +1597,7 @@ extra args."
(let ((calls (assq name byte-compile-unresolved-functions))
nums sig min max)
(when (and calls macrop)
- (byte-compile-warn "macro `%s' defined too late" name))
+ (byte-compile-warn-x name "macro `%s' defined too late" name))
(setq byte-compile-unresolved-functions
(delq calls byte-compile-unresolved-functions))
(setq calls (delq t calls)) ;Ignore higher-order uses of the function.
@@ -1598,16 +1605,16 @@ extra args."
(when (and (symbolp name)
(eq (function-get name 'byte-optimizer)
'byte-compile-inline-expand))
- (byte-compile-warn "defsubst `%s' was used before it was defined"
- name))
+ (byte-compile-warn-x name "defsubst `%s' was used before it was
defined"
+ name))
(setq sig (byte-compile-arglist-signature arglist)
nums (sort (copy-sequence (cddr calls)) (function <))
min (car nums)
max (car (nreverse nums)))
(when (or (< min (car sig))
(and (cdr sig) (> max (cdr sig))))
- (byte-compile-set-symbol-position name)
- (byte-compile-warn
+ (byte-compile-warn-x
+ name
"%s being defined to take %s%s, but was previously called with %s"
name
(byte-compile-arglist-signature-string sig)
@@ -1625,8 +1632,8 @@ extra args."
(let ((sig1 (byte-compile--function-signature old))
(sig2 (byte-compile-arglist-signature arglist)))
(unless (byte-compile-arglist-signatures-congruent-p sig1 sig2)
- (byte-compile-set-symbol-position name)
- (byte-compile-warn
+ (byte-compile-warn-x
+ name
"%s %s used to take %s %s, now takes %s"
(if macrop "macro" "function")
name
@@ -1715,8 +1722,10 @@ It is too wide if it has any lines longer than the
largest of
(setq name (if name (format " `%s' " name) ""))
(when (and kind docs (stringp docs)
(byte-compile--wide-docstring-p docs col))
- (byte-compile-warn "%s%sdocstring wider than %s characters"
- kind name col))))
+ (byte-compile-warn-x
+ name
+ "%s%sdocstring wider than %s characters"
+ kind name col))))
form)
;; If we have compiled any calls to functions which are not known to be
@@ -1730,10 +1739,10 @@ It is too wide if it has any lines longer than the
largest of
(dolist (urf byte-compile-unresolved-functions)
(let ((f (car urf)))
(when (not (memq f byte-compile-new-defuns))
- (let ((byte-compile-last-position (cadr urf)))
- (byte-compile-warn
- (if (fboundp f) "the function `%s' might not be defined at
runtime." "the function `%s' is not known to be defined.")
- (car urf))))))))
+ (byte-compile-warn-x
+ f
+ (if (fboundp f) "the function `%s' might not be defined at
runtime." "the function `%s' is not known to be defined.")
+ (car urf)))))))
nil)
@@ -1789,7 +1798,8 @@ It is too wide if it has any lines longer than the
largest of
(warning-series-started
(and (markerp warning-series)
(eq (marker-buffer warning-series)
- (get-buffer byte-compile-log-buffer)))))
+ (get-buffer byte-compile-log-buffer))))
+ (byte-compile-form-stack byte-compile-form-stack))
(if (or (eq warning-series 'byte-compile-warning-series)
warning-series-started)
;; warning-series does come from compilation,
@@ -2199,19 +2209,22 @@ With argument ARG, insert value in current buffer after
the form."
(save-excursion
(end-of-defun)
(beginning-of-defun)
- (let* ((byte-compile-current-file (current-buffer))
+ (let* ((print-symbols-bare t)
+ (byte-compile-current-file (current-buffer))
(byte-compile-current-buffer (current-buffer))
- (byte-compile-read-position (point))
- (byte-compile-last-position byte-compile-read-position)
+ (start-read-position (point))
(byte-compile-last-warned-form 'nothing)
(value (eval
(let ((read-with-symbol-positions (current-buffer))
- (read-symbol-positions-list nil))
+ (read-symbol-positions-list nil)
+ (symbols-with-pos-enabled t))
(displaying-byte-compile-warnings
(byte-compile-sexp
- (eval-sexp-add-defvars
- (read (current-buffer))
- byte-compile-read-position))))
+ (let ((form (read-positioning-symbols
(current-buffer))))
+ (push form byte-compile-form-stack)
+ (eval-sexp-add-defvars
+ form
+ start-read-position)))))
lexical-binding)))
(cond (arg
(message "Compiling from buffer... done.")
@@ -2221,8 +2234,6 @@ With argument ARG, insert value in current buffer after
the form."
(defun byte-compile-from-buffer (inbuffer)
(let ((byte-compile-current-buffer inbuffer)
- (byte-compile-read-position nil)
- (byte-compile-last-position nil)
;; Prevent truncation of flonums and lists as we read and print them
(float-output-format nil)
(case-fold-search nil)
@@ -2245,7 +2256,7 @@ With argument ARG, insert value in current buffer after
the form."
(read-symbol-positions-list nil)
;; #### This is bound in b-c-close-variables.
;; (byte-compile-warnings byte-compile-warnings)
- )
+ (symbols-with-pos-enabled t))
(byte-compile-close-variables
(with-current-buffer
(setq byte-compile--outbuffer
@@ -2291,18 +2302,14 @@ With argument ARG, insert value in current buffer after
the form."
(= (following-char) ?\;))
(forward-line 1))
(not (eobp)))
- (setq byte-compile-read-position (point)
- byte-compile-last-position byte-compile-read-position)
(let* ((lread--unescaped-character-literals nil)
+ (load-read-function #'read-positioning-symbols)
(form (funcall load-read-function inbuffer))
(warning (byte-run--unescaped-character-literals-warning)))
- (when warning (byte-compile-warn "%s" warning))
+ (when warning (byte-compile-warn-x form "%s" warning))
(byte-compile-toplevel-file-form form)))
;; Compile pending forms at end of file.
(byte-compile-flush-pending)
- ;; Make warnings about unresolved functions
- ;; give the end of the file as their position.
- (setq byte-compile-last-position (point-max))
(byte-compile-warn-about-unresolved-functions)))
byte-compile--outbuffer)))
@@ -2360,7 +2367,8 @@ Call from the source buffer."
;; Spill output for the native compiler here
(push (make-byte-to-native-top-level :form form :lexical lexical-binding)
byte-to-native-top-level-forms))
- (let ((print-escape-newlines t)
+ (let ((print-symbols-bare t)
+ (print-escape-newlines t)
(print-length nil)
(print-level nil)
(print-quoted t)
@@ -2395,8 +2403,8 @@ list that represents a doc string reference.
;; in the input buffer (now current), not in the output buffer.
(let ((dynamic-docstrings byte-compile-dynamic-docstrings))
(with-current-buffer byte-compile--outbuffer
- (let (position)
-
+ (let (position
+ (print-symbols-bare t))
;; Insert the doc string, and make it a comment with #@LENGTH.
(and (>= (nth 1 info) 0)
dynamic-docstrings
@@ -2506,7 +2514,8 @@ list that represents a doc string reference.
byte-compile-jump-tables nil))))
(defun byte-compile-preprocess (form &optional _for-effect)
- (setq form (macroexpand-all form byte-compile-macro-environment))
+ (let ((print-symbols-bare t))
+ (setq form (macroexpand-all form byte-compile-macro-environment)))
;; FIXME: We should run byte-optimize-form here, but it currently does not
;; recurse through all the code, so we'd have to fix this first.
;; Maybe a good fix would be to merge byte-optimize-form into
@@ -2519,11 +2528,16 @@ list that represents a doc string reference.
;; byte-hunk-handlers cannot call this!
(defun byte-compile-toplevel-file-form (top-level-form)
- (byte-compile-recurse-toplevel
- top-level-form
- (lambda (form)
- (let ((byte-compile-current-form nil)) ; close over this for warnings.
- (byte-compile-file-form (byte-compile-preprocess form t))))))
+ ;; (let ((byte-compile-form-stack
+ ;; (cons top-level-form byte-compile-form-stack)))
+ (push top-level-form byte-compile-form-stack)
+ (prog1
+ (byte-compile-recurse-toplevel
+ top-level-form
+ (lambda (form)
+ (let ((byte-compile-current-form nil)) ; close over this for warnings.
+ (byte-compile-file-form (byte-compile-preprocess form t)))))
+ (pop byte-compile-form-stack)))
;; byte-hunk-handlers can call this.
(defun byte-compile-file-form (form)
@@ -2572,7 +2586,8 @@ list that represents a doc string reference.
(delq (assq funsym byte-compile-unresolved-functions)
byte-compile-unresolved-functions)))))
(if (stringp (nth 3 form))
- (prog1 form
+ (prog1
+ form
(byte-compile-docstring-length-warn form))
;; No doc string, so we can compile this as a normal form.
(byte-compile-keep-pending form 'byte-compile-normal-call)))
@@ -2584,7 +2599,8 @@ list that represents a doc string reference.
(when (and (symbolp sym)
(not (string-match "[-*/:$]" (symbol-name sym)))
(byte-compile-warning-enabled-p 'lexical sym))
- (byte-compile-warn "global/dynamic var `%s' lacks a prefix" sym)))
+ (byte-compile-warn-x
+ sym "global/dynamic var `%s' lacks a prefix" sym)))
(defun byte-compile--declare-var (sym)
(byte-compile--check-prefixed-var sym)
@@ -2592,7 +2608,7 @@ list that represents a doc string reference.
(setq byte-compile-lexical-variables
(delq sym byte-compile-lexical-variables))
(when (byte-compile-warning-enabled-p 'lexical sym)
- (byte-compile-warn "Variable `%S' declared after its first use" sym)))
+ (byte-compile-warn-x sym "Variable `%S' declared after its first use"
sym)))
(push sym byte-compile-bound-variables)
(push sym byte-compile--seen-defvars))
@@ -2605,10 +2621,16 @@ list that represents a doc string reference.
(eq (car form) 'defvar)) ;Just a declaration.
nil
(byte-compile-docstring-length-warn form)
+ (setq form (copy-sequence form))
(cond ((consp (nth 2 form))
- (setq form (copy-sequence form))
(setcar (cdr (cdr form))
- (byte-compile-top-level (nth 2 form) nil 'file))))
+ (byte-compile-top-level (nth 2 form) nil 'file)))
+ ((symbolp (nth 2 form))
+ (setcar (cddr form) (bare-symbol (nth 2 form))))
+ (t (setcar (cddr form) (nth 2 form))))
+ (setcar form (bare-symbol (car form)))
+ (if (symbolp (nth 1 form))
+ (setcar (cdr form) (bare-symbol (nth 1 form))))
form))
(put 'define-abbrev-table 'byte-hunk-handler
@@ -2626,7 +2648,8 @@ list that represents a doc string reference.
(`(defvaralias ,_ ',newname . ,_)
(when (memq newname byte-compile-bound-variables)
(if (byte-compile-warning-enabled-p 'suspicious)
- (byte-compile-warn
+ (byte-compile-warn-x
+ newname
"Alias for `%S' should be declared before its referent"
newname)))))
(byte-compile-docstring-length-warn form)
(byte-compile-keep-pending form))
@@ -2640,8 +2663,11 @@ list that represents a doc string reference.
(put 'require 'byte-hunk-handler 'byte-compile-file-form-require)
(defun byte-compile-file-form-require (form)
- (let ((args (mapcar 'eval (cdr form)))
- hist-new prov-cons)
+ (let* ((args (mapcar 'eval (cdr form)))
+ ;; The following is for the byte-compile-warn in
+ ;; `do-after-load-evaluation' (in subr.el).
+ (byte-compile-form-stack (cons (car args) byte-compile-form-stack))
+ hist-new prov-cons)
(apply 'require args)
;; Record the functions defined by the require in
`byte-compile-new-defuns'.
@@ -2685,7 +2711,8 @@ list that represents a doc string reference.
(put 'make-obsolete 'byte-hunk-handler 'byte-compile-file-form-make-obsolete)
(defun byte-compile-file-form-make-obsolete (form)
(prog1 (byte-compile-keep-pending form)
- (apply 'make-obsolete (mapcar 'eval (cdr form)))))
+ (apply 'make-obsolete
+ (mapcar 'eval (cdr form)))))
(defun byte-compile-file-form-defmumble (name macro arglist body rest)
"Process a `defalias' for NAME.
@@ -2700,23 +2727,23 @@ not to take responsibility for the actual compilation
of the code."
'byte-compile-macro-environment))
(this-one (assq name (symbol-value this-kind)))
(that-one (assq name (symbol-value that-kind)))
+ (bare-name (bare-symbol name))
(byte-compile-current-form name)) ; For warnings.
- (byte-compile-set-symbol-position name)
- (push name byte-compile-new-defuns)
+ (push bare-name byte-compile-new-defuns)
;; When a function or macro is defined, add it to the call tree so that
;; we can tell when functions are not used.
(if byte-compile-generate-call-tree
- (or (assq name byte-compile-call-tree)
+ (or (assq bare-name byte-compile-call-tree)
(setq byte-compile-call-tree
- (cons (list name nil nil) byte-compile-call-tree))))
+ (cons (list bare-name nil nil) byte-compile-call-tree))))
(if (byte-compile-warning-enabled-p 'redefine name)
(byte-compile-arglist-warn name arglist macro))
(if byte-compile-verbose
(message "Compiling %s... (%s)"
- (or byte-compile-current-file "") name))
+ (or byte-compile-current-file "") bare-name))
(cond ((not (or macro (listp body)))
;; We do not know positively if the definition is a macro
;; or a function, so we shouldn't emit warnings.
@@ -2725,29 +2752,34 @@ not to take responsibility for the actual compilation
of the code."
(that-one
(if (and (byte-compile-warning-enabled-p 'redefine name)
;; Don't warn when compiling the stubs in byte-run...
- (not (assq name byte-compile-initial-macro-environment)))
- (byte-compile-warn
+ (not (assq bare-name
byte-compile-initial-macro-environment)))
+ (byte-compile-warn-x
+ name
"`%s' defined multiple times, as both function and macro"
- name))
+ bare-name))
(setcdr that-one nil))
(this-one
(when (and (byte-compile-warning-enabled-p 'redefine name)
;; Hack: Don't warn when compiling the magic internal
;; byte-compiler macros in byte-run.el...
- (not (assq name byte-compile-initial-macro-environment)))
- (byte-compile-warn "%s `%s' defined multiple times in this file"
- (if macro "macro" "function")
- name)))
- ((eq (car-safe (symbol-function name))
+ (not (assq bare-name
byte-compile-initial-macro-environment)))
+ (byte-compile-warn-x
+ name
+ "%s `%s' defined multiple times in this file"
+ (if macro "macro" "function")
+ bare-name)))
+ ((eq (car-safe (symbol-function bare-name))
(if macro 'lambda 'macro))
- (when (byte-compile-warning-enabled-p 'redefine name)
- (byte-compile-warn "%s `%s' being redefined as a %s"
- (if macro "function" "macro")
- name
- (if macro "macro" "function")))
+ (when (byte-compile-warning-enabled-p 'redefine bare-name)
+ (byte-compile-warn-x
+ name
+ "%s `%s' being redefined as a %s"
+ (if macro "function" "macro")
+ bare-name
+ (if macro "macro" "function")))
;; Shadow existing definition.
(set this-kind
- (cons (cons name nil)
+ (cons (cons bare-name nil)
(symbol-value this-kind))))
)
@@ -2756,10 +2788,8 @@ not to take responsibility for the actual compilation of
the code."
(symbolp (car-safe (cdr-safe body)))
(car-safe (cdr-safe body))
(stringp (car-safe (cdr-safe (cdr-safe body)))))
- ;; FIXME: We've done that already just above, so this looks wrong!
- ;;(byte-compile-set-symbol-position name)
- (byte-compile-warn "probable `\"' without `\\' in doc string of %s"
- name))
+ (byte-compile-warn-x
+ name "probable `\"' without `\\' in doc string of %s" bare-name))
(if (not (listp body))
;; The precise definition requires evaluation to find out, so it
@@ -2767,7 +2797,7 @@ not to take responsibility for the actual compilation of
the code."
;; For a macro, that means we can't use that macro in the same file.
(progn
(unless macro
- (push (cons name (if (listp arglist) `(declared ,arglist) t))
+ (push (cons bare-name (if (listp arglist) `(declared ,arglist) t))
byte-compile-function-environment))
;; Tell the caller that we didn't compile it yet.
nil)
@@ -2777,10 +2807,10 @@ not to take responsibility for the actual compilation
of the code."
;; A definition in b-c-initial-m-e should always take precedence
;; during compilation, so don't let it be redefined. (Bug#8647)
(or (and macro
- (assq name byte-compile-initial-macro-environment))
+ (assq bare-name byte-compile-initial-macro-environment))
(setcdr this-one code))
(set this-kind
- (cons (cons name code)
+ (cons (cons bare-name code)
(symbol-value this-kind))))
(if rest
@@ -2796,18 +2826,19 @@ not to take responsibility for the actual compilation
of the code."
(if (not (stringp (documentation code t))) -1 4)))
(when byte-native-compiling
;; Spill output for the native compiler here.
- (push (if macro
- (make-byte-to-native-top-level
- :form `(defalias ',name '(macro . ,code) nil)
- :lexical lexical-binding)
- (make-byte-to-native-func-def :name name
- :byte-func code))
- byte-to-native-top-level-forms))
+ (push
+ (if macro
+ (make-byte-to-native-top-level
+ :form `(defalias ',name '(macro . ,code) nil)
+ :lexical lexical-binding)
+ (make-byte-to-native-func-def :name name
+ :byte-func code))
+ byte-to-native-top-level-forms))
;; Output the form by hand, that's much simpler than having
;; b-c-output-file-form analyze the defalias.
(byte-compile-output-docform
"\n(defalias '"
- name
+ bare-name
(if macro `(" '(macro . #[" ,index "])") `(" #[" ,index "]"))
(append code nil) ; Turn byte-code-function-p into list.
(and (atom code) byte-compile-dynamic
@@ -2890,37 +2921,38 @@ If FORM is a lambda or a macro, byte-compile it as a
function."
(macro (eq (car-safe fun) 'macro)))
(if macro
(setq fun (cdr fun)))
- (cond
- ;; Up until Emacs-24.1, byte-compile silently did nothing when asked to
- ;; compile something invalid. So let's tune down the complaint from an
- ;; error to a simple message for the known case where signaling an error
- ;; causes problems.
- ((byte-code-function-p fun)
- (message "Function %s is already compiled"
- (if (symbolp form) form "provided"))
- fun)
- (t
- (let (final-eval)
- (when (or (symbolp form) (eq (car-safe fun) 'closure))
- ;; `fun' is a function *value*, so try to recover its corresponding
- ;; source code.
- (setq lexical-binding (eq (car fun) 'closure))
- (setq fun (byte-compile--reify-function fun))
- (setq final-eval t))
- ;; Expand macros.
- (setq fun (byte-compile-preprocess fun))
- (setq fun (byte-compile-top-level fun nil 'eval))
- (if (symbolp form)
- ;; byte-compile-top-level returns an *expression* equivalent to
the
- ;; `fun' expression, so we need to evaluate it, tho normally
- ;; this is not needed because the expression is just a constant
- ;; byte-code object, which is self-evaluating.
- (setq fun (eval fun t)))
- (if final-eval
- (setq fun (eval fun t)))
- (if macro (push 'macro fun))
- (if (symbolp form) (fset form fun))
- fun)))))))
+ (prog1
+ (cond
+ ;; Up until Emacs-24.1, byte-compile silently did nothing when
asked to
+ ;; compile something invalid. So let's tune down the complaint
from an
+ ;; error to a simple message for the known case where signaling an
error
+ ;; causes problems.
+ ((byte-code-function-p fun)
+ (message "Function %s is already compiled"
+ (if (symbolp form) form "provided"))
+ fun)
+ (t
+ (let (final-eval)
+ (when (or (symbolp form) (eq (car-safe fun) 'closure))
+ ;; `fun' is a function *value*, so try to recover its
corresponding
+ ;; source code.
+ (setq lexical-binding (eq (car fun) 'closure))
+ (setq fun (byte-compile--reify-function fun))
+ (setq final-eval t))
+ ;; Expand macros.
+ (setq fun (byte-compile-preprocess fun))
+ (setq fun (byte-compile-top-level fun nil 'eval))
+ (if (symbolp form)
+ ;; byte-compile-top-level returns an *expression* equivalent
to the
+ ;; `fun' expression, so we need to evaluate it, tho normally
+ ;; this is not needed because the expression is just a
constant
+ ;; byte-code object, which is self-evaluating.
+ (setq fun (eval fun t)))
+ (if final-eval
+ (setq fun (eval fun t)))
+ (if macro (push 'macro fun))
+ (if (symbolp form) (fset form fun))
+ fun))))))))
(defun byte-compile-sexp (sexp)
"Compile and return SEXP."
@@ -2933,8 +2965,6 @@ If FORM is a lambda or a macro, byte-compile it as a
function."
(let (vars)
(while list
(let ((arg (car list)))
- (when (symbolp arg)
- (byte-compile-set-symbol-position arg))
(cond ((or (not (symbolp arg))
(macroexp--const-symbol-p arg t))
(error "Invalid lambda variable %s" arg))
@@ -2951,7 +2981,8 @@ If FORM is a lambda or a macro, byte-compile it as a
function."
((and (memq arg vars)
;; Allow repetitions for unused args.
(not (string-match "\\`_" (symbol-name arg))))
- (byte-compile-warn "repeated variable %s in lambda-list" arg))
+ (byte-compile-warn-x
+ arg "repeated variable %s in lambda-list" arg))
(t
(push arg vars))))
(setq list (cdr list)))))
@@ -2994,7 +3025,8 @@ If FORM is a lambda or a macro, byte-compile it as a
function."
(defun byte-compile--warn-lexical-dynamic (var context)
(when (byte-compile-warning-enabled-p 'lexical-dynamic var)
- (byte-compile-warn
+ (byte-compile-warn-x
+ var
"`%s' lexically bound in %s here but declared dynamic in: %s"
var context
(mapconcat #'identity
@@ -3006,16 +3038,11 @@ If FORM is a lambda or a macro, byte-compile it as a
function."
(defun byte-compile-lambda (fun &optional add-lambda reserved-csts)
"Byte-compile a lambda-expression and return a valid function.
The value is usually a compiled function but may be the original
-lambda-expression.
-When ADD-LAMBDA is non-nil, the symbol `lambda' is added as head
-of the list FUN and `byte-compile-set-symbol-position' is not called.
-Use this feature to avoid calling `byte-compile-set-symbol-position'
-for symbols generated by the byte compiler itself."
+lambda-expression."
(if add-lambda
(setq fun (cons 'lambda fun))
(unless (eq 'lambda (car-safe fun))
- (error "Not a lambda list: %S" fun))
- (byte-compile-set-symbol-position 'lambda))
+ (error "Not a lambda list: %S" fun)))
(byte-compile-docstring-length-warn fun)
(byte-compile-check-lambda-list (nth 1 fun))
(let* ((arglist (nth 1 fun))
@@ -3038,7 +3065,6 @@ for symbols generated by the byte compiler itself."
(byte-compile--warn-lexical-dynamic var 'lambda))))
;; Process the interactive spec.
(when int
- (byte-compile-set-symbol-position 'interactive)
;; Skip (interactive) if it is in front (the most usual location).
(if (eq int (car body))
(setq body (cdr body)))
@@ -3046,8 +3072,8 @@ for symbols generated by the byte compiler itself."
;; Check that the bit after the `interactive' spec is
;; just a list of symbols (i.e., modes).
(unless (seq-every-p #'symbolp (cdr (cdr int)))
- (byte-compile-warn "malformed interactive specc: %s"
- (prin1-to-string int)))
+ (byte-compile-warn-x int "malformed interactive specc: %s"
+ int))
(setq command-modes (cdr (cdr int)))
;; If the interactive spec is a call to `list', don't
;; compile it, because `call-interactively' looks at the
@@ -3059,16 +3085,16 @@ for symbols generated by the byte compiler itself."
(while (consp (cdr form))
(setq form (cdr form)))
(setq form (car form)))
- (when (or (not (eq (car-safe form) 'list))
- ;; For code using lexical-binding, form is not
- ;; valid lisp, but rather an intermediate form
- ;; which may include "calls" to
- ;; internal-make-closure (Bug#29988).
- lexical-binding)
- (setq int `(interactive ,newform)))))
+ (if (or (not (eq (car-safe form) 'list))
+ ;; For code using lexical-binding, form is not
+ ;; valid lisp, but rather an intermediate form
+ ;; which may include "calls" to
+ ;; internal-make-closure (Bug#29988).
+ lexical-binding)
+ (setq int `(interactive ,newform)))))
((cdr int) ; Invalid (interactive . something).
- (byte-compile-warn "malformed interactive spec: %s"
- (prin1-to-string int)))))
+ (byte-compile-warn-x int "malformed interactive spec: %s"
+ int))))
;; Process the body.
(let ((compiled
(byte-compile-top-level (cons 'progn body) nil 'lambda
@@ -3079,14 +3105,15 @@ for symbols generated by the byte compiler itself."
(and lexical-binding
(byte-compile-make-lambda-lexenv
arglistvars))
- reserved-csts)))
+ reserved-csts))
+ (bare-arglist arglist))
;; Build the actual byte-coded function.
(cl-assert (eq 'byte-code (car-safe compiled)))
(let ((out
(apply #'make-byte-code
(if lexical-binding
(byte-compile-make-args-desc arglist)
- arglist)
+ bare-arglist)
(append
;; byte-string, constants-vector, stack depth
(cdr compiled)
@@ -3094,7 +3121,7 @@ for symbols generated by the byte compiler itself."
(cond ((and lexical-binding arglist)
;; byte-compile-make-args-desc lost the args's
names,
;; so preserve them in the docstring.
- (list (help-add-fundoc-usage doc arglist)))
+ (list (help-add-fundoc-usage doc bare-arglist)))
((or doc int)
(list doc)))
;; optionally, the interactive spec (and the modes the
@@ -3299,7 +3326,8 @@ for symbols generated by the byte compiler itself."
(setq byte-compile-noruntime-functions
(delq fn byte-compile-noruntime-functions))
;; Delegate the rest to the normal macro definition.
- (macroexpand `(declare-function ,fn ,file ,@args)))
+ (let ((print-symbols-bare t))
+ (macroexpand `(declare-function ,fn ,file ,@args))))
;; This is the recursive entry point for compiling each subform of an
@@ -3317,18 +3345,16 @@ for symbols generated by the byte compiler itself."
;;
(defun byte-compile-form (form &optional for-effect)
(let ((byte-compile--for-effect for-effect))
+ (push form byte-compile-form-stack)
(cond
((not (consp form))
(cond ((or (not (symbolp form)) (macroexp--const-symbol-p form))
- (when (symbolp form)
- (byte-compile-set-symbol-position form))
- (byte-compile-constant form))
+ (byte-compile-constant
+ (if (symbolp form) (bare-symbol form) form)))
((and byte-compile--for-effect byte-compile-delete-errors)
- (when (symbolp form)
- (byte-compile-set-symbol-position form))
(setq byte-compile--for-effect nil))
(t
- (byte-compile-variable-ref form))))
+ (byte-compile-variable-ref (bare-symbol form)))))
((symbolp (car form))
(let* ((fn (car form))
(handler (get fn 'byte-compile))
@@ -3351,20 +3377,20 @@ for symbols generated by the byte compiler itself."
(byte-compile-check-variable (cadr hook) nil))))
(when (and (byte-compile-warning-enabled-p 'suspicious)
(macroexp--const-symbol-p fn))
- (byte-compile-warn "`%s' called as a function" fn))
+ (byte-compile-warn-x fn "`%s' called as a function" fn))
(when (and (byte-compile-warning-enabled-p 'interactive-only fn)
interactive-only)
- (byte-compile-warn "`%s' is for interactive use only%s"
- fn
- (cond ((stringp interactive-only)
- (format "; %s"
- (substitute-command-keys
- interactive-only)))
- ((and (symbolp 'interactive-only)
- (not (eq interactive-only t)))
- (format-message "; use `%s' instead."
- interactive-only))
- (t "."))))
+ (byte-compile-warn-x fn "`%s' is for interactive use only%s"
+ fn
+ (cond ((stringp interactive-only)
+ (format "; %s"
+ (substitute-command-keys
+ interactive-only)))
+ ((and (symbolp 'interactive-only)
+ (not (eq interactive-only t)))
+ (format-message "; use `%s' instead."
+ interactive-only))
+ (t "."))))
(if (eq (car-safe (symbol-function (car form))) 'macro)
(byte-compile-report-error
(format "`%s' defined after use in %S (missing `require' of a
library file?)"
@@ -3389,7 +3415,8 @@ for symbols generated by the byte compiler itself."
(setq byte-compile--for-effect nil))
((byte-compile-normal-call form)))
(if byte-compile--for-effect
- (byte-compile-discard))))
+ (byte-compile-discard))
+ (pop byte-compile-form-stack)))
(defun byte-compile-normal-call (form)
(when (and (symbolp (car form))
@@ -3403,8 +3430,8 @@ for symbols generated by the byte compiler itself."
(byte-compile-annotate-call-tree form))
(when (and byte-compile--for-effect (eq (car form) 'mapcar)
(byte-compile-warning-enabled-p 'mapcar 'mapcar))
- (byte-compile-set-symbol-position 'mapcar)
- (byte-compile-warn
+ (byte-compile-warn-x
+ (car form)
"`mapcar' called for effect; use `mapc' or `dolist' instead"))
(byte-compile-push-constant (car form))
(mapc 'byte-compile-form (cdr form)) ; wasteful, but faster.
@@ -3535,16 +3562,16 @@ for symbols generated by the byte compiler itself."
(defun byte-compile-check-variable (var access-type)
"Do various error checks before a use of the variable VAR."
- (when (symbolp var)
- (byte-compile-set-symbol-position var))
(cond ((or (not (symbolp var)) (macroexp--const-symbol-p var))
(when (byte-compile-warning-enabled-p 'constants
(and (symbolp var) var))
- (byte-compile-warn (if (eq access-type 'let-bind)
- "attempt to let-bind %s `%s'"
- "variable reference to %s `%s'")
- (if (symbolp var) "constant" "nonvariable")
- (prin1-to-string var))))
+ (byte-compile-warn-x
+ var
+ (if (eq access-type 'let-bind)
+ "attempt to let-bind %s `%s'"
+ "variable reference to %s `%s'")
+ (if (symbolp var) "constant" "nonvariable")
+ var)))
((let ((od (get var 'byte-obsolete-variable)))
(and od
(not (memq var byte-compile-not-obsolete-vars))
@@ -3557,6 +3584,7 @@ for symbols generated by the byte compiler itself."
(byte-compile-warn-obsolete var))))
(defsubst byte-compile-dynamic-variable-op (base-op var)
+ (if (symbolp var) (setq var (bare-symbol var)))
(let ((tmp (assq var byte-compile-variables)))
(unless tmp
(setq tmp (list var))
@@ -3569,9 +3597,10 @@ for symbols generated by the byte compiler itself."
(push var byte-compile-bound-variables)
(byte-compile-dynamic-variable-op 'byte-varbind var))
-(defun byte-compile-free-vars-warn (var &optional assignment)
+(defun byte-compile-free-vars-warn (arg var &optional assignment)
"Warn if symbol VAR refers to a free variable.
VAR must not be lexically bound.
+ARG is a position argument, used by byte-compile-warn-x.
If optional argument ASSIGNMENT is non-nil, this is treated as an
assignment (i.e. `setq')."
(unless (or (not (byte-compile-warning-enabled-p 'free-vars var))
@@ -3583,9 +3612,9 @@ assignment (i.e. `setq')."
(let* ((varname (prin1-to-string var))
(desc (if assignment "assignment" "reference"))
(suggestions (help-uni-confusable-suggestions varname)))
- (byte-compile-warn "%s to free variable `%s'%s"
- desc varname
- (if suggestions (concat "\n " suggestions) "")))
+ (byte-compile-warn-x arg "%s to free variable `%s'%s"
+ desc var
+ (if suggestions (concat "\n " suggestions) "")))
(push var (if assignment
byte-compile-free-assignments
byte-compile-free-references))))
@@ -3598,7 +3627,7 @@ assignment (i.e. `setq')."
;; VAR is lexically bound
(byte-compile-stack-ref (cdr lex-binding))
;; VAR is dynamically bound
- (byte-compile-free-vars-warn var)
+ (byte-compile-free-vars-warn var var)
(byte-compile-dynamic-variable-op 'byte-varref var))))
(defun byte-compile-variable-set (var)
@@ -3609,7 +3638,7 @@ assignment (i.e. `setq')."
;; VAR is lexically bound.
(byte-compile-stack-set (cdr lex-binding))
;; VAR is dynamically bound.
- (byte-compile-free-vars-warn var t)
+ (byte-compile-free-vars-warn var var t)
(byte-compile-dynamic-variable-op 'byte-varset var))))
(defmacro byte-compile-get-constant (const)
@@ -3629,14 +3658,17 @@ assignment (i.e. `setq')."
(defun byte-compile-constant (const)
(if byte-compile--for-effect
(setq byte-compile--for-effect nil)
- (inline (byte-compile-push-constant const))))
+ (inline (byte-compile-push-constant
+ (if (symbolp const) (bare-symbol const) const)))))
;; Use this for a constant that is not the value of its containing form.
;; This ignores byte-compile--for-effect.
(defun byte-compile-push-constant (const)
(when (symbolp const)
- (byte-compile-set-symbol-position const))
- (byte-compile-out 'byte-constant (byte-compile-get-constant const)))
+ (setq const (bare-symbol const)))
+ (byte-compile-out
+ 'byte-constant
+ (byte-compile-get-constant const)))
;; Compile those primitive ordinary functions
;; which have special byte codes just for speed.
@@ -3788,10 +3820,10 @@ If it is nil, then the handler is
\"byte-compile-SYMBOL.\""
(defun byte-compile-subr-wrong-args (form n)
- (byte-compile-set-symbol-position (car form))
- (byte-compile-warn "`%s' called with %d arg%s, but requires %s"
- (car form) (length (cdr form))
- (if (= 1 (length (cdr form))) "" "s") n)
+ (byte-compile-warn-x (car form)
+ "`%s' called with %d arg%s, but requires %s"
+ (car form) (length (cdr form))
+ (if (= 1 (length (cdr form))) "" "s") n)
;; Get run-time wrong-number-of-args error.
(byte-compile-normal-call form))
@@ -4100,7 +4132,8 @@ discarding."
(if (eq 'interactive (car-safe (car body))) (setq body (cdr body)))
(if (and (consp (car body))
(not (eq 'byte-code (car (car body)))))
- (byte-compile-warn
+ (byte-compile-warn-x
+ (nth 2 form)
"A quoted lambda form is the second argument of `fset'. This is probably
not what you want, as that lambda cannot be compiled. Consider using
the syntax #'(lambda (...) ...) instead.")))))
@@ -4185,10 +4218,11 @@ discarding."
(macroexp--const-symbol-p var t))
(byte-compile-warning-enabled-p 'constants
(and (symbolp var) var))
- (byte-compile-warn
+ (byte-compile-warn-x
+ var
"variable assignment to %s `%s'"
(if (symbolp var) "constant" "nonvariable")
- (prin1-to-string var)))))
+ var))))
(byte-compile-normal-call form)))
(defun byte-compile-quote (form)
@@ -4721,7 +4755,6 @@ binding slots have been popped."
;; Even when optimization is off, /= is optimized to (not (= ...)).
(defun byte-compile-negation-optimizer (form)
;; an optimizer for forms where <form1> is less efficient than (not <form2>)
- (byte-compile-set-symbol-position (car form))
(list 'not
(cons (or (get (car form) 'byte-compile-negated-op)
(error
@@ -4771,18 +4804,17 @@ binding slots have been popped."
(cons (byte-compile-make-tag) clause))
failure-handlers))
(endtag (byte-compile-make-tag)))
- (byte-compile-set-symbol-position 'condition-case)
(unless (symbolp var)
- (byte-compile-warn
- "`%s' is not a variable-name or nil (in condition-case)" var))
+ (byte-compile-warn-x
+ var "`%s' is not a variable-name or nil (in condition-case)" var))
(dolist (clause (reverse clauses))
(let ((condition (nth 1 clause)))
(unless (consp condition) (setq condition (list condition)))
(dolist (c condition)
(unless (and c (symbolp c))
- (byte-compile-warn
- "`%S' is not a condition name (in condition-case)" c))
+ (byte-compile-warn-x
+ c "`%S' is not a condition name (in condition-case)" c))
;; In reality, the `error-conditions' property is only required
;; for the argument to `signal', not to `condition-case'.
;;(unless (consp (get c 'error-conditions))
@@ -4833,7 +4865,8 @@ binding slots have been popped."
(defun byte-compile-save-excursion (form)
(if (and (eq 'set-buffer (car-safe (car-safe (cdr form))))
(byte-compile-warning-enabled-p 'suspicious 'set-buffer))
- (byte-compile-warn
+ (byte-compile-warn-x
+ form
"Use `with-current-buffer' rather than save-excursion+set-buffer"))
(byte-compile-out 'byte-save-excursion 0)
(byte-compile-body-do-effect (cdr form))
@@ -4874,18 +4907,20 @@ binding slots have been popped."
(when (and (symbolp (nth 1 form))
(not (string-match "[-*/:$]" (symbol-name (nth 1 form))))
(byte-compile-warning-enabled-p 'lexical (nth 1 form)))
- (byte-compile-warn "global/dynamic var `%s' lacks a prefix"
- (nth 1 form)))
+ (byte-compile-warn-x
+ (nth 1 form)
+ "global/dynamic var `%s' lacks a prefix"
+ (nth 1 form)))
(byte-compile-docstring-length-warn form)
(let ((fun (nth 0 form))
(var (nth 1 form))
(value (nth 2 form))
(string (nth 3 form)))
- (byte-compile-set-symbol-position fun)
(when (or (> (length form) 4)
(and (eq fun 'defconst) (null (cddr form))))
(let ((ncall (length (cdr form))))
- (byte-compile-warn
+ (byte-compile-warn-x
+ fun
"`%s' called with %d argument%s, but %s %s"
fun ncall
(if (= 1 ncall) "" "s")
@@ -4895,8 +4930,10 @@ binding slots have been popped."
(if (eq fun 'defconst)
(push var byte-compile-const-variables))
(when (and string (not (stringp string)))
- (byte-compile-warn "third arg to `%s %s' is not a string: %s"
- fun var string))
+ (byte-compile-warn-x
+ string
+ "third arg to `%s %s' is not a string: %s"
+ fun var string))
(byte-compile-form-do-effect
(if (cddr form) ; `value' provided
;; Quote with `quote' to prevent byte-compiling the body,
@@ -4911,12 +4948,12 @@ binding slots have been popped."
`',var)))))
(defun byte-compile-autoload (form)
- (byte-compile-set-symbol-position 'autoload)
(and (macroexp-const-p (nth 1 form))
(macroexp-const-p (nth 5 form))
(memq (eval (nth 5 form)) '(t macro)) ; macro-p
(not (fboundp (eval (nth 1 form))))
- (byte-compile-warn
+ (byte-compile-warn-x
+ form
"The compiler ignores `autoload' except at top level. You should
probably put the autoload of the macro `%s' at top-level."
(eval (nth 1 form))))
@@ -4925,7 +4962,6 @@ binding slots have been popped."
;; Lambdas in valid places are handled as special cases by various code.
;; The ones that remain are errors.
(defun byte-compile-lambda-form (_form)
- (byte-compile-set-symbol-position 'lambda)
(error "`lambda' used as function name is invalid"))
;; Compile normally, but deal with warnings for the function being defined.
@@ -5005,7 +5041,8 @@ binding slots have been popped."
(defun byte-compile-make-variable-buffer-local (form)
(if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote)
(byte-compile-warning-enabled-p 'make-local))
- (byte-compile-warn
+ (byte-compile-warn-x
+ form
"`make-variable-buffer-local' not called at toplevel"))
(byte-compile-normal-call form))
(put 'make-variable-buffer-local
@@ -5109,24 +5146,26 @@ OP and OPERAND are as passed to `byte-compile-out'."
;;; call tree stuff
(defun byte-compile-annotate-call-tree (form)
- (let (entry)
+ (let ((current-form (byte-run-strip-symbol-positions
+ byte-compile-current-form))
+ (bare-car-form (byte-run-strip-symbol-positions (car form)))
+ entry)
;; annotate the current call
- (if (setq entry (assq (car form) byte-compile-call-tree))
- (or (memq byte-compile-current-form (nth 1 entry)) ;callers
+ (if (setq entry (assq bare-car-form byte-compile-call-tree))
+ (or (memq current-form (nth 1 entry)) ;callers
(setcar (cdr entry)
- (cons byte-compile-current-form (nth 1 entry))))
+ (cons current-form (nth 1 entry))))
(setq byte-compile-call-tree
- (cons (list (car form) (list byte-compile-current-form) nil)
+ (cons (list bare-car-form (list current-form) nil)
byte-compile-call-tree)))
;; annotate the current function
- (if (setq entry (assq byte-compile-current-form byte-compile-call-tree))
- (or (memq (car form) (nth 2 entry)) ;called
+ (if (setq entry (assq current-form byte-compile-call-tree))
+ (or (memq bare-car-form (nth 2 entry)) ;called
(setcar (cdr (cdr entry))
- (cons (car form) (nth 2 entry))))
+ (cons bare-car-form (nth 2 entry))))
(setq byte-compile-call-tree
- (cons (list byte-compile-current-form nil (list (car form)))
- byte-compile-call-tree)))
- ))
+ (cons (list current-form nil (list bare-car-form))
+ byte-compile-call-tree)))))
;; Renamed from byte-compile-report-call-tree
;; to avoid interfering with completion of byte-compile-file.
@@ -5151,14 +5190,15 @@ invoked interactively."
(set-buffer "*Call-Tree*")
(erase-buffer)
(message "Generating call tree... (sorting on %s)"
- byte-compile-call-tree-sort)
+ (remove-pos-from-symbol byte-compile-call-tree-sort))
(insert "Call tree for "
(cond ((null byte-compile-current-file) (or filename "???"))
((stringp byte-compile-current-file)
byte-compile-current-file)
(t (buffer-name byte-compile-current-file)))
" sorted on "
- (prin1-to-string byte-compile-call-tree-sort)
+ (prin1-to-string (remove-pos-from-symbol
+ byte-compile-call-tree-sort))
":\n\n")
(if byte-compile-call-tree-sort
(setq byte-compile-call-tree
@@ -5178,7 +5218,8 @@ invoked interactively."
('name
(lambda (x y) (string< (car x) (car y))))
(_ (error "`byte-compile-call-tree-sort': `%s' - unknown
sort mode"
- byte-compile-call-tree-sort))))))
+ (remove-pos-from-symbol
+ byte-compile-call-tree-sort)))))))
(message "Generating call tree...")
(let ((rest byte-compile-call-tree)
(b (current-buffer))
@@ -5325,7 +5366,7 @@ already up-to-date."
(or (not (file-exists-p dest))
(file-newer-than-file-p source dest))))
(if (null (batch-byte-compile-file (car command-line-args-left)))
- (setq error t))))
+ (setq error t))))
(setq command-line-args-left (cdr command-line-args-left)))
(kill-emacs (if error 1 0))))
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index e114ef1075..7b22121db0 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -258,11 +258,11 @@ Returns a form where all lambdas don't have any free
variables."
;; unused vars.
(not (intern-soft var))
(eq ?_ (aref (symbol-name var) 0))
- ;; As a special exception, ignore "ignore".
+ ;; As a special exception, ignore "ignored".
(eq var 'ignored))
(let ((suggestions (help-uni-confusable-suggestions (symbol-name var))))
(format "Unused lexical %s `%S'%s"
- varkind var
+ varkind (bare-symbol var)
(if suggestions (concat "\n " suggestions) "")))))
(define-inline cconv--var-classification (binder form)
@@ -286,7 +286,7 @@ of converted forms."
(let (and (pred stringp) msg)
(cconv--warn-unused-msg arg "argument")))
(if (assq arg env) (push `(,arg . nil) env)) ;FIXME: Is it needed?
- (push (lambda (body) (macroexp--warn-wrap msg body 'lexical))
wrappers))
+ (push (lambda (body) (macroexp--warn-wrap body msg body 'lexical))
wrappers))
(_
(if (assq arg env) (push `(,arg . nil) env)))))
(setq funcbody (mapcar (lambda (form)
@@ -367,7 +367,8 @@ places where they originally did not directly appear."
(var (if (not (consp binder))
(prog1 binder (setq binder (list binder)))
(when (cddr binder)
- (byte-compile-warn
+ (byte-compile-warn-x
+ binder
"Malformed `%S' binding: %S"
letsym binder))
(setq value (cadr binder))
@@ -375,9 +376,9 @@ places where they originally did not directly appear."
(cond
;; Ignore bindings without a valid name.
((not (symbolp var))
- (byte-compile-warn "attempt to let-bind nonvariable `%S'" var))
+ (byte-compile-warn-x var "attempt to let-bind nonvariable `%S'"
var))
((or (booleanp var) (keywordp var))
- (byte-compile-warn "attempt to let-bind constant `%S'" var))
+ (byte-compile-warn-x var "attempt to let-bind constant `%S'" var))
(t
(let ((new-val
(pcase (cconv--var-classification binder form)
@@ -427,11 +428,14 @@ places where they originally did not directly appear."
;; Declared variable is unused.
(if (assq var new-env)
(push `(,var) new-env)) ;FIXME:Needed?
- (let ((newval
- `(ignore ,(cconv-convert value env extend)))
- (msg (cconv--warn-unused-msg var "variable")))
+ (let* ((Ignore (if (symbol-with-pos-p var)
+ (position-symbol 'ignore var)
+ 'ignore))
+ (newval `(,Ignore
+ ,(cconv-convert value env extend)))
+ (msg (cconv--warn-unused-msg var "variable")))
(if (null msg) newval
- (macroexp--warn-wrap msg newval 'lexical))))
+ (macroexp--warn-wrap var msg newval 'lexical))))
;; Normal default case.
(_
@@ -530,7 +534,7 @@ places where they originally did not directly appear."
(newprotform (cconv-convert protected-form env extend)))
`(condition-case ,var
,(if msg
- (macroexp--warn-wrap msg newprotform 'lexical)
+ (macroexp--warn-wrap var msg newprotform 'lexical)
newprotform)
,@(mapcar
(lambda (handler)
@@ -624,7 +628,8 @@ FORM is the parent form that binds this var."
;; FIXME: Convert this warning to use `macroexp--warn-wrap'
;; so as to give better position information.
(when (byte-compile-warning-enabled-p 'not-unused var)
- (byte-compile-warn "%s `%S' not left unused" varkind var)))
+ (byte-compile-warn-x
+ var "%s `%S' not left unused" varkind var)))
((and (let (or 'let* 'let) (car form))
`((,var) ;; (or `(,var nil) : Too many false positives: bug#47080
t nil ,_ ,_))
@@ -632,7 +637,7 @@ FORM is the parent form that binds this var."
;; so as to give better position information and obey
;; `byte-compile-warnings'.
(unless (not (intern-soft var))
- (byte-compile-warn "Variable `%S' left uninitialized" var))))
+ (byte-compile-warn-x var "Variable `%S' left uninitialized" var))))
(pcase vardata
(`(,binder nil ,_ ,_ nil)
(push (cons (cons binder form) :unused) cconv-var-classification))
@@ -661,7 +666,8 @@ FORM is the parent form that binds this var."
(dolist (arg args)
(cond
((byte-compile-not-lexical-var-p arg)
- (byte-compile-warn
+ (byte-compile-warn-x
+ arg
"Lexical argument shadows the dynamic variable %S"
arg))
((eq ?& (aref (symbol-name arg) 0)) nil) ;Ignore &rest, &optional, ...
@@ -744,7 +750,8 @@ This function does not return anything but instead fills the
(setq forms (cddr forms))))
(`((lambda . ,_) . ,_) ; First element is lambda expression.
- (byte-compile-warn
+ (byte-compile-warn-x
+ (nth 1 (car form))
"Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form)))
(dolist (exp `((function ,(car form)) . ,(cdr form)))
(cconv-analyze-form exp env)))
@@ -763,8 +770,8 @@ This function does not return anything but instead fills the
(`(condition-case ,var ,protected-form . ,handlers)
(cconv-analyze-form protected-form env)
(when (and var (symbolp var) (byte-compile-not-lexical-var-p var))
- (byte-compile-warn
- "Lexical variable shadows the dynamic variable %S" var))
+ (byte-compile-warn-x
+ var "Lexical variable shadows the dynamic variable %S" var))
(let* ((varstruct (list var nil nil nil nil)))
(if var (push varstruct env))
(dolist (handler handlers)
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index 5090e06037..53691881ec 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -498,7 +498,8 @@ The set of acceptable TYPEs (also called \"specializers\")
is defined
cl--generic-edebug-make-name nil]
lambda-doc ; documentation string
def-body))) ; part to be debugged
- (let ((qualifiers nil))
+ (let ((qualifiers nil)
+ (org-name name))
(while (cl-generic--method-qualifier-p args)
(push args qualifiers)
(setq args (pop body)))
@@ -513,6 +514,7 @@ The set of acceptable TYPEs (also called \"specializers\")
is defined
(byte-compile-warning-enabled-p 'obsolete name))
(let* ((obsolete (get name 'byte-obsolete-info)))
(macroexp-warn-and-return
+ org-name
(macroexp--obsolete-warning name obsolete "generic function")
nil)))
;; You could argue that `defmethod' modifies rather than defines the
diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el
index 66c269b658..470168177c 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2429,10 +2429,12 @@ by EXPANSION, and (setq NAME ...) will act like (setf
EXPANSION ...).
(append bindings venv))
macroexpand-all-environment))))
(if malformed-bindings
- (macroexp-warn-and-return
- (format-message "Malformed `cl-symbol-macrolet' binding(s):
%S"
- (nreverse malformed-bindings))
- expansion)
+ (let ((rev-malformed-bindings (nreverse malformed-bindings)))
+ (macroexp-warn-and-return
+ rev-malformed-bindings
+ (format-message "Malformed `cl-symbol-macrolet' binding(s):
%S"
+ rev-malformed-bindings)
+ expansion))
expansion)))
(unless advised
(advice-remove 'macroexpand #'cl--sm-macroexpand)))))
@@ -3116,6 +3118,7 @@ To see the documentation for a defined struct type, use
(when (cl-oddp (length desc))
(push
(macroexp-warn-and-return
+ (car (last desc))
(format "Missing value for option `%S' of slot `%s' in
struct %s!"
(car (last desc)) slot name)
'nil)
@@ -3125,6 +3128,7 @@ To see the documentation for a defined struct type, use
(let ((kw (car defaults)))
(push
(macroexp-warn-and-return
+ kw
(format " I'll take `%s' to be an option rather than a
default value."
kw)
'nil)
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index c9cb2b1c7b..74b0b1197b 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -1831,9 +1831,7 @@ and the annotation emission."
(byte-listp auto)
(byte-eq auto)
(byte-memq auto)
- (byte-not
- (comp-emit-set-call (comp-call 'eq (comp-slot-n (comp-sp))
- (make-comp-mvar :constant nil))))
+ (byte-not null)
(byte-car auto)
(byte-cdr auto)
(byte-cons auto)
@@ -3570,7 +3568,7 @@ Update all insn accordingly."
;; Symbols imported by C inlined functions. We do this here because
;; is better to add all objs to the relocation containers before we
;; compacting them.
- (mapc #'comp-add-const-to-relocs '(nil t consp listp))
+ (mapc #'comp-add-const-to-relocs '(nil t consp listp symbol-with-pos-p))
(let* ((d-default (comp-ctxt-d-default comp-ctxt))
(d-default-idx (comp-data-container-idx d-default))
@@ -4006,9 +4004,12 @@ the deferred compilation mechanism."
(signal 'native-compiler-error
(list "Not a function symbol or file" function-or-file)))
(catch 'no-native-compile
- (let* ((data function-or-file)
+ (let* ((print-symbols-bare t)
+ (max-specpdl-size (max max-specpdl-size 5000))
+ (data function-or-file)
(comp-native-compiling t)
(byte-native-qualities nil)
+ (symbols-with-pos-enabled t)
;; Have byte compiler signal an error when compilation fails.
(byte-compile-debug t)
(comp-ctxt (make-comp-ctxt :output output
@@ -4052,10 +4053,10 @@ the deferred compilation mechanism."
(signal (car err) (if (consp err-val)
(cons function-or-file err-val)
(list function-or-file err-val)))))))
- (if (stringp function-or-file)
- data
- ;; So we return the compiled function.
- (native-elisp-load data)))))
+ (if (stringp function-or-file)
+ data
+ ;; So we return the compiled function.
+ (native-elisp-load data)))))
(defun native-compile-async-skip-p (file load selector)
"Return non-nil if FILE's compilation should be skipped.
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index 688c76e0c5..7bcb2f2936 100644
--- a/lisp/emacs-lisp/easy-mmode.el
+++ b/lisp/emacs-lisp/easy-mmode.el
@@ -230,6 +230,7 @@ INIT-VALUE LIGHTER KEYMAP.
(warnwrap (if (or (null body) (keywordp (car body))) #'identity
(lambda (exp)
(macroexp-warn-and-return
+ exp
"Use keywords rather than deprecated positional
arguments to `define-minor-mode'"
exp))))
keyw keymap-sym tmp)
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index f36e34261e..33aabf4a48 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -748,6 +748,7 @@ Argument FN is the function calling this verifier."
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-slot-names))))
(macroexp-warn-and-return
+ name
(format-message "Unknown slot `%S'" name)
exp nil 'compile-only))
(_ exp))))
@@ -784,11 +785,13 @@ Fills in CLASS's SLOT with its default value."
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-slot-names))))
(macroexp-warn-and-return
+ name
(format-message "Unknown slot `%S'" name)
exp nil 'compile-only))
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-class-slot-names))))
(macroexp-warn-and-return
+ name
(format-message "Slot `%S' is not class-allocated" name)
exp nil 'compile-only))
(_ exp)))))
@@ -846,11 +849,13 @@ Fills in the default value in CLASS' in SLOT with VALUE."
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-slot-names))))
(macroexp-warn-and-return
+ name
(format-message "Unknown slot `%S'" name)
exp nil 'compile-only))
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-class-slot-names))))
(macroexp-warn-and-return
+ name
(format-message "Slot `%S' is not class-allocated" name)
exp nil 'compile-only))
(_ exp)))))
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 27bdedb306..820e8383d8 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -181,9 +181,11 @@ and reference them using the function `class-option'."
;; Is there an initarg, but allocation of class?
(when (and initarg (eq alloc :class))
- (push (format "Meaningless :initarg for class allocated slot '%S'"
- sname)
- warnings))
+ (push
+ (cons sname
+ (format "Meaningless :initarg for class allocated slot '%S'"
+ sname))
+ warnings))
(let ((init (plist-get soptions :initform)))
(unless (or (macroexp-const-p init)
@@ -194,8 +196,9 @@ and reference them using the function `class-option'."
;; heuristic says and if it disagrees with normal evaluation
;; then tweak the initform to make it fit and emit
;; a warning accordingly.
- (push (format "Ambiguous initform needs quoting: %S" init)
- warnings)))
+ (push
+ (cons init (format "Ambiguous initform needs quoting: %S" init))
+ warnings)))
;; Anyone can have an accessor function. This creates a function
;; of the specified name, and also performs a `defsetf' if applicable
@@ -242,7 +245,8 @@ This method is obsolete."
`(progn
,@(mapcar (lambda (w)
- (macroexp-warn-and-return w `(progn ',w) nil 'compile-only))
+ (macroexp-warn-and-return
+ (car w) (cdr w) `(progn ',(cdr w)) nil 'compile-only))
warnings)
;; This test must be created right away so we can have self-
;; referencing classes. ei, a class whose slot can contain only
@@ -292,6 +296,7 @@ This method is obsolete."
(if (not (stringp (car slots)))
whole
(macroexp-warn-and-return
+ (car slots)
(format "Obsolete name arg %S to constructor %S"
(car slots) (car whole))
;; Keep the name arg, for backward compatibility,
diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el
index 1e9793261f..91538d1f06 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -581,7 +581,9 @@ This is like the `&' operator of the C language.
Note: this only works reliably with lexical binding mode, except for very
simple PLACEs such as (symbol-function \\='foo) which will also work in dynamic
binding mode."
- (let ((code
+ (let ((org-place place) ; It's too difficult to determine by inspection
whether
+ ; the functions modify place.
+ (code
(gv-letplace (getter setter) place
`(cons (lambda () ,getter)
(lambda (gv--val) ,(funcall setter 'gv--val))))))
@@ -593,6 +595,7 @@ binding mode."
(eq (car-safe code) 'cons))
code
(macroexp-warn-and-return
+ org-place
"Use of gv-ref probably requires lexical-binding"
code))))
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el
index 33ce55a3de..256092599b 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -28,6 +28,17 @@
;;; Code:
+(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.
+
+Normally a form is manually pushed onto the list at the beginning
+of `byte-compile-form', etc., and manually popped off at its end.
+This is to preserve the data in it in the event of a
+condition-case handling a signaled error.")
+
;; Bound by the top-level `macroexpand-all', and modified to include any
;; macros defined by `defmacro'.
(defvar macroexpand-all-environment nil)
@@ -96,10 +107,11 @@ each clause."
(defun macroexp--compiler-macro (handler form)
(condition-case-unless-debug err
- (apply handler form (cdr form))
+ (let ((symbols-with-pos-enabled t))
+ (apply handler form (cdr form)))
(error
- (message "Compiler-macro error for %S: %S" (car form) err)
- form)))
+ (message "Compiler-macro error for %S: Handler: %S\n%S" (car form)
handler err)
+ form)))
(defun macroexp--funcall-if-compiled (_form)
"Pseudo function used internally by macroexp to delay warnings.
@@ -135,21 +147,23 @@ Other uses risk returning non-nil value that point to the
wrong file."
(defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key))
-(defun macroexp--warn-wrap (msg form category)
+(defun macroexp--warn-wrap (arg msg form category)
(let ((when-compiled
(lambda ()
(when (if (consp category)
(apply #'byte-compile-warning-enabled-p category)
(byte-compile-warning-enabled-p category))
- (byte-compile-warn "%s" msg)))))
+ (byte-compile-warn-x arg "%s" msg)))))
`(progn
(macroexp--funcall-if-compiled ',when-compiled)
,form)))
(define-obsolete-function-alias 'macroexp--warn-and-return
#'macroexp-warn-and-return "28.1")
-(defun macroexp-warn-and-return (msg form &optional category compile-only)
+(defun macroexp-warn-and-return (arg msg form &optional category compile-only)
"Return code equivalent to FORM labeled with warning MSG.
+ARG is a symbol (or a form) giving the source code position of FORM
+for the message. It should normally be a symbol with position.
CATEGORY is the category of the warning, like the categories that
can appear in `byte-compile-warnings'.
COMPILE-ONLY non-nil means no warning should be emitted if the code
@@ -163,7 +177,7 @@ is executed without being compiled first."
;; macroexpand-all gets right back to macroexpanding `form'.
form
(puthash form form macroexp--warned)
- (macroexp--warn-wrap msg form category)))
+ (macroexp--warn-wrap arg msg form category)))
(t
(unless compile-only
(message "%sWarning: %s"
@@ -219,6 +233,7 @@ is executed without being compiled first."
(let* ((fun (car form))
(obsolete (get fun 'byte-obsolete-info)))
(macroexp-warn-and-return
+ fun
(macroexp--obsolete-warning
fun obsolete
(if (symbolp (symbol-function fun))
@@ -274,6 +289,7 @@ is executed without being compiled first."
(setq arglist (cdr arglist)))
(if values
(macroexp-warn-and-return
+ arglist
(format (if (eq values 'too-few)
"attempt to open-code `%s' with too few arguments"
"attempt to open-code `%s' with too many arguments")
@@ -303,122 +319,124 @@ Only valid during macro-expansion."
"Expand all macros in FORM.
This is an internal version of `macroexpand-all'.
Assumes the caller has bound `macroexpand-all-environment'."
- (if (eq (car-safe form) 'backquote-list*)
- ;; Special-case `backquote-list*', as it is normally a macro that
- ;; generates exceedingly deep expansions from relatively shallow input
- ;; forms. We just process it `in reverse' -- first we expand all the
- ;; arguments, _then_ we expand the top-level definition.
- (macroexpand (macroexp--all-forms form 1)
- macroexpand-all-environment)
- ;; Normal form; get its expansion, and then expand arguments.
- (setq form (macroexp-macroexpand form macroexpand-all-environment))
- ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when
- ;; I tried it, it broke the bootstrap :-(
- (pcase form
- (`(cond . ,clauses)
- (macroexp--cons 'cond (macroexp--all-clauses clauses) form))
- (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare))
- (macroexp--cons
- 'condition-case
- (macroexp--cons err
- (macroexp--cons (macroexp--expand-all body)
- (macroexp--all-clauses handlers 1)
- (cddr form))
- (cdr form))
- form))
- (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_)
- (push name macroexp--dynvars)
- (macroexp--all-forms form 2))
- (`(function ,(and f `(lambda . ,_)))
- (let ((macroexp--dynvars macroexp--dynvars))
- (macroexp--cons 'function
- (macroexp--cons (macroexp--all-forms f 2)
- nil
- (cdr form))
- form)))
- (`(,(or 'function 'quote) . ,_) form)
- (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body)
- pcase--dontcare))
- (let ((macroexp--dynvars macroexp--dynvars))
- (macroexp--cons
- fun
- (macroexp--cons
- (macroexp--all-clauses bindings 1)
- (if (null body)
- (macroexp-unprogn
- (macroexp-warn-and-return
- (format "Empty %s body" fun)
- nil nil 'compile-only))
- (macroexp--all-forms body))
- (cdr form))
- form)))
- (`(,(and fun `(lambda . ,_)) . ,args)
- ;; Embedded lambda in function position.
- ;; If the byte-optimizer is loaded, try to unfold this,
- ;; i.e. rewrite it to (let (<args>) <body>). We'd do it in the
optimizer
- ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the
- ;; creation of a closure, thus resulting in much better code.
- (let ((newform (macroexp--unfold-lambda form)))
- (if (eq newform form)
- ;; Unfolding failed for some reason, avoid infinite recursion.
- (macroexp--cons (macroexp--all-forms fun 2)
- (macroexp--all-forms args)
- form)
- (macroexp--expand-all newform))))
-
- (`(funcall ,exp . ,args)
- (let ((eexp (macroexp--expand-all exp))
- (eargs (macroexp--all-forms args)))
- ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
- ;; has a compiler-macro, or to unfold it.
- (pcase eexp
- ((and `#',f
- (guard (not (or (special-form-p f) (macrop f)))));; bug#46636
- (macroexp--expand-all `(,f . ,eargs)))
- (_ `(funcall ,eexp . ,eargs)))))
- (`(funcall . ,_) form) ;bug#53227
-
- (`(,func . ,_)
- (let ((handler (function-get func 'compiler-macro))
- (funargs (function-get func 'funarg-positions)))
- ;; Check functions quoted with ' rather than with #'
- (dolist (funarg funargs)
- (let ((arg (nth funarg form)))
- (when (and (eq 'quote (car-safe arg))
- (eq 'lambda (car-safe (cadr arg))))
- (setcar (nthcdr funarg form)
- (macroexp-warn-and-return
- (format "%S quoted with ' rather than with #'"
- (let ((f (cadr arg)))
- (if (symbolp f) f `(lambda ,(nth 1 f) ...))))
- arg)))))
- ;; Macro expand compiler macros. This cannot be delayed to
- ;; byte-optimize-form because the output of the compiler-macro can
- ;; use macros.
- (if (null handler)
- ;; No compiler macro. We just expand each argument (for
- ;; setq/setq-default this works alright because the variable names
- ;; are symbols).
- (macroexp--all-forms form 1)
- ;; If the handler is not loaded yet, try (auto)loading the
- ;; function itself, which may in turn load the handler.
- (unless (functionp handler)
- (with-demoted-errors "macroexp--expand-all: %S"
- (autoload-do-load (indirect-function func) func)))
- (let ((newform (macroexp--compiler-macro handler form)))
- (if (eq form newform)
- ;; The compiler macro did not find anything to do.
- (if (equal form (setq newform (macroexp--all-forms form 1)))
- form
- ;; Maybe after processing the args, some new opportunities
- ;; appeared, so let's try the compiler macro again.
- (setq form (macroexp--compiler-macro handler newform))
- (if (eq newform form)
- newform
- (macroexp--expand-all newform)))
- (macroexp--expand-all newform))))))
-
- (_ form))))
+ (push form byte-compile-form-stack)
+ (prog1
+ (if (eq (car-safe form) 'backquote-list*)
+ ;; Special-case `backquote-list*', as it is normally a macro that
+ ;; generates exceedingly deep expansions from relatively shallow
input
+ ;; forms. We just process it `in reverse' -- first we expand all the
+ ;; arguments, _then_ we expand the top-level definition.
+ (macroexpand (macroexp--all-forms form 1)
+ macroexpand-all-environment)
+ ;; Normal form; get its expansion, and then expand arguments.
+ (setq form (macroexp-macroexpand form macroexpand-all-environment))
+ ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when
+ ;; I tried it, it broke the bootstrap :-(
+ (pcase form
+ (`(cond . ,clauses)
+ (macroexp--cons 'cond (macroexp--all-clauses clauses) form))
+ (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare))
+ (macroexp--cons
+ 'condition-case
+ (macroexp--cons err
+ (macroexp--cons (macroexp--expand-all body)
+ (macroexp--all-clauses handlers 1)
+ (cddr form))
+ (cdr form))
+ form))
+ (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_)
+ (push name macroexp--dynvars)
+ (macroexp--all-forms form 2))
+ (`(function ,(and f `(lambda . ,_)))
+ (let ((macroexp--dynvars macroexp--dynvars))
+ (macroexp--cons 'function
+ (macroexp--cons (macroexp--all-forms f 2)
+ nil
+ (cdr form))
+ form)))
+ (`(,(or 'function 'quote) . ,_) form)
+ (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body)
+ pcase--dontcare))
+ (let ((macroexp--dynvars macroexp--dynvars))
+ (macroexp--cons
+ fun
+ (macroexp--cons
+ (macroexp--all-clauses bindings 1)
+ (if (null body)
+ (macroexp-unprogn
+ (macroexp-warn-and-return
+ fun
+ (format "Empty %s body" fun)
+ nil nil 'compile-only))
+ (macroexp--all-forms body))
+ (cdr form))
+ form)))
+ (`(,(and fun `(lambda . ,_)) . ,args)
+ ;; Embedded lambda in function position.
+ ;; If the byte-optimizer is loaded, try to unfold this,
+ ;; i.e. rewrite it to (let (<args>) <body>). We'd do it in the
optimizer
+ ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the
+ ;; creation of a closure, thus resulting in much better code.
+ (let ((newform (macroexp--unfold-lambda form)))
+ (if (eq newform form)
+ ;; Unfolding failed for some reason, avoid infinite recursion.
+ (macroexp--cons (macroexp--all-forms fun 2)
+ (macroexp--all-forms args)
+ form)
+ (macroexp--expand-all newform))))
+ (`(funcall ,exp . ,args)
+ (let ((eexp (macroexp--expand-all exp))
+ (eargs (macroexp--all-forms args)))
+ ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo'
+ ;; has a compiler-macro, or to unfold it.
+ (pcase eexp
+ ((and `#',f
+ (guard (not (or (special-form-p f) (macrop f))))) ;;
bug#46636
+ (macroexp--expand-all `(,f . ,eargs)))
+ (_ `(funcall ,eexp . ,eargs)))))
+ (`(funcall . ,_) form) ;bug#53227
+ (`(,func . ,_)
+ (let ((handler (function-get func 'compiler-macro))
+ (funargs (function-get func 'funarg-positions)))
+ ;; Check functions quoted with ' rather than with #'
+ (dolist (funarg funargs)
+ (let ((arg (nth funarg form)))
+ (when (and (eq 'quote (car-safe arg))
+ (eq 'lambda (car-safe (cadr arg))))
+ (setcar (nthcdr funarg form)
+ (macroexp-warn-and-return
+ (cadr arg)
+ (format "%S quoted with ' rather than with #'"
+ (let ((f (cadr arg)))
+ (if (symbolp f) f `(lambda ,(nth 1 f)
...))))
+ arg)))))
+ ;; Macro expand compiler macros. This cannot be delayed to
+ ;; byte-optimize-form because the output of the compiler-macro can
+ ;; use macros.
+ (if (null handler)
+ ;; No compiler macro. We just expand each argument (for
+ ;; setq/setq-default this works alright because the variable
names
+ ;; are symbols).
+ (macroexp--all-forms form 1)
+ ;; If the handler is not loaded yet, try (auto)loading the
+ ;; function itself, which may in turn load the handler.
+ (unless (functionp handler)
+ (with-demoted-errors "macroexp--expand-all: %S"
+ (autoload-do-load (indirect-function func) func)))
+ (let ((newform (macroexp--compiler-macro handler form)))
+ (if (eq form newform)
+ ;; The compiler macro did not find anything to do.
+ (if (equal form (setq newform (macroexp--all-forms form
1)))
+ form
+ ;; Maybe after processing the args, some new
opportunities
+ ;; appeared, so let's try the compiler macro again.
+ (setq form (macroexp--compiler-macro handler newform))
+ (if (eq newform form)
+ newform
+ (macroexp--expand-all newform)))
+ (macroexp--expand-all newform))))))
+ (_ form)))
+ (pop byte-compile-form-stack)))
;; Record which arguments expect functions, so we can warn when those
;; are accidentally quoted with ' rather than with #'
@@ -708,38 +726,40 @@ test of free variables in the following ways:
(defun internal-macroexpand-for-load (form full-p)
;; Called from the eager-macroexpansion in readevalloop.
- (cond
- ;; Don't repeat the same warning for every top-level element.
- ((eq 'skip (car macroexp--pending-eager-loads)) form)
- ;; If we detect a cycle, skip macro-expansion for now, and output a warning
- ;; with a trimmed backtrace.
- ((and load-file-name (member load-file-name macroexp--pending-eager-loads))
- (let* ((bt (delq nil
- (mapcar #'macroexp--trim-backtrace-frame
- (macroexp--backtrace))))
- (elem `(load ,(file-name-nondirectory load-file-name)))
- (tail (member elem (cdr (member elem bt)))))
- (if tail (setcdr tail (list '…)))
- (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt)))
- (if macroexp--debug-eager
- (debug 'eager-macroexp-cycle)
- (message "Warning: Eager macro-expansion skipped due to cycle:\n %s"
- (mapconcat #'prin1-to-string (nreverse bt) " => ")))
- (push 'skip macroexp--pending-eager-loads)
- form))
- (t
- (condition-case err
- (let ((macroexp--pending-eager-loads
- (cons load-file-name macroexp--pending-eager-loads)))
- (if full-p
- (macroexpand--all-toplevel form)
- (macroexpand form)))
- (error
- ;; Hopefully this shouldn't happen thanks to the cycle detection,
- ;; but in case it does happen, let's catch the error and give the
- ;; code a chance to macro-expand later.
- (message "Eager macro-expansion failure: %S" err)
- form)))))
+ (let ((symbols-with-pos-enabled t)
+ (print-symbols-bare t))
+ (cond
+ ;; Don't repeat the same warning for every top-level element.
+ ((eq 'skip (car macroexp--pending-eager-loads)) form)
+ ;; If we detect a cycle, skip macro-expansion for now, and output a
warning
+ ;; with a trimmed backtrace.
+ ((and load-file-name (member load-file-name
macroexp--pending-eager-loads))
+ (let* ((bt (delq nil
+ (mapcar #'macroexp--trim-backtrace-frame
+ (macroexp--backtrace))))
+ (elem `(load ,(file-name-nondirectory load-file-name)))
+ (tail (member elem (cdr (member elem bt)))))
+ (if tail (setcdr tail (list '…)))
+ (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt)))
+ (if macroexp--debug-eager
+ (debug 'eager-macroexp-cycle)
+ (message "Warning: Eager macro-expansion skipped due to cycle:\n %s"
+ (mapconcat #'prin1-to-string (nreverse bt) " => ")))
+ (push 'skip macroexp--pending-eager-loads)
+ form))
+ (t
+ (condition-case err
+ (let ((macroexp--pending-eager-loads
+ (cons load-file-name macroexp--pending-eager-loads)))
+ (if full-p
+ (macroexpand--all-toplevel form)
+ (macroexpand form)))
+ (error
+ ;; Hopefully this shouldn't happen thanks to the cycle detection,
+ ;; but in case it does happen, let's catch the error and give the
+ ;; code a chance to macro-expand later.
+ (message "Eager macro-expansion failure: %S" err)
+ form))))))
;; ¡¡¡ Big Ugly Hack !!!
;; src/bootstrap-emacs is mostly used to compile .el files, so it needs
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 7a82b416e5..c3dbfe2947 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -433,6 +433,7 @@ how many time this CODEGEN is called."
(memq (car case) pcase--dontwarn-upats))
(setq main
(macroexp-warn-and-return
+ (car case)
(format "pcase pattern %S shadowed by previous pcase pattern"
(car case))
main))))
@@ -940,6 +941,7 @@ Otherwise, it defers to REST which is a list of branches of
the form
(let ((code (pcase--u1 matches code vars rest)))
(if (eq upat '_) code
(macroexp-warn-and-return
+ upat
"Pattern t is deprecated. Use `_' instead"
code))))
((eq upat 'pcase--dontcare) :pcase--dontcare)
diff --git a/lisp/help.el b/lisp/help.el
index b142cce845..983f39479c 100644
--- a/lisp/help.el
+++ b/lisp/help.el
@@ -2069,7 +2069,7 @@ the same names as used in the original source code, when
possible."
((symbolp arg)
(let ((name (symbol-name arg)))
(cond
- ((string-match "\\`&" name) arg)
+ ((string-match "\\`&" name) (bare-symbol arg))
((string-match "\\`_." name)
(intern (upcase (substring name 1))))
(t (intern (upcase name))))))
diff --git a/lisp/keymap.el b/lisp/keymap.el
index 4dbf9cf72f..c0fdf8721b 100644
--- a/lisp/keymap.el
+++ b/lisp/keymap.el
@@ -462,18 +462,19 @@ If MESSAGE (and interactively), message the result."
(keywordp (car args))
(not (eq (car args) :menu)))
(unless (memq (car args) '(:full :keymap :parent :suppress :name :prefix))
- (byte-compile-warn "Invalid keyword: %s" (car args)))
+ (byte-compile-warn-x (car args) "Invalid keyword: %s" (car args)))
(setq args (cdr args))
(when (null args)
- (byte-compile-warn "Uneven number of keywords in %S" form))
+ (byte-compile-warn-x form "Uneven number of keywords in %S" form))
(setq args (cdr args)))
;; Bindings.
(while args
- (let ((key (pop args)))
+ (let* ((wargs args)
+ (key (pop args)))
(when (and (stringp key) (not (key-valid-p key)))
- (byte-compile-warn "Invalid `kbd' syntax: %S" key)))
+ (byte-compile-warn-x wargs "Invalid `kbd' syntax: %S" key)))
(when (null args)
- (byte-compile-warn "Uneven number of key bindings in %S" form))
+ (byte-compile-warn-x form "Uneven number of key bindings in %S" form))
(setq args (cdr args)))
form)
diff --git a/src/.gdbinit b/src/.gdbinit
index 132f414af9..9ec536a96d 100644
--- a/src/.gdbinit
+++ b/src/.gdbinit
@@ -751,6 +751,15 @@ Print $ as a overlay pointer.
This command assumes that $ is an Emacs Lisp overlay value.
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
set $sym = $
xgetsym $sym
@@ -1016,6 +1025,9 @@ define xpr
if $vec == PVEC_OVERLAY
xoverlay
end
+ if $vec == PVEC_SYMBOL_WITH_POS
+ xsymwithpos
+ end
if $vec == PVEC_PROCESS
xprocess
end
diff --git a/src/alloc.c b/src/alloc.c
index 7582a42601..e0b2c22023 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -592,7 +592,7 @@ pointer_align (void *ptr, int alignment)
static ATTRIBUTE_NO_SANITIZE_UNDEFINED void *
XPNTR (Lisp_Object a)
{
- return (SYMBOLP (a)
+ return (BARE_SYMBOL_P (a)
? (char *) lispsym + (XLI (a) - LISP_WORD_TAG (Lisp_Symbol))
: (char *) XLP (a) - (XLI (a) & ~VALMASK));
}
@@ -3599,13 +3599,13 @@ static struct Lisp_Symbol *symbol_free_list;
static void
set_symbol_name (Lisp_Object sym, Lisp_Object name)
{
- XSYMBOL (sym)->u.s.name = name;
+ XBARE_SYMBOL (sym)->u.s.name = name;
}
void
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_plist (val, Qnil);
p->u.s.redirect = SYMBOL_PLAINVAL;
@@ -3668,6 +3668,21 @@ make_misc_ptr (void *a)
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. */
Lisp_Object
@@ -5212,7 +5227,7 @@ valid_lisp_object_p (Lisp_Object obj)
if (PURE_P (p))
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;
if (p == &buffer_defaults || p == &buffer_local_symbols)
@@ -5640,12 +5655,12 @@ purecopy (Lisp_Object obj)
vec->contents[i] = purecopy (vec->contents[i]);
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.
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;
}
/* Don't hash-cons it. */
@@ -6273,7 +6288,10 @@ For further details, see Info node `(elisp)Garbage
Collection'. */)
if (garbage_collection_inhibited)
return Qnil;
+ ptrdiff_t count = SPECPDL_INDEX ();
+ specbind (Qsymbols_with_pos_enabled, Qnil);
garbage_collect ();
+ unbind_to (count, Qnil);
struct gcstat gcst = gcstat;
Lisp_Object total[] = {
@@ -6412,7 +6430,7 @@ mark_char_table (struct Lisp_Vector *ptr, enum pvec_type
pvectype)
Lisp_Object val = ptr->contents[i];
if (FIXNUMP (val) ||
- (SYMBOLP (val) && symbol_marked_p (XSYMBOL (val))))
+ (BARE_SYMBOL_P (val) && symbol_marked_p (XBARE_SYMBOL (val))))
continue;
if (SUB_CHAR_TABLE_P (val))
{
@@ -6816,7 +6834,7 @@ mark_object (Lisp_Object arg)
case Lisp_Symbol:
{
- struct Lisp_Symbol *ptr = XSYMBOL (obj);
+ struct Lisp_Symbol *ptr = XBARE_SYMBOL (obj);
nextsym:
if (symbol_marked_p (ptr))
break;
@@ -6937,7 +6955,7 @@ survives_gc_p (Lisp_Object obj)
break;
case Lisp_Symbol:
- survives_p = symbol_marked_p (XSYMBOL (obj));
+ survives_p = symbol_marked_p (XBARE_SYMBOL (obj));
break;
case Lisp_String:
@@ -7354,7 +7372,7 @@ arenas. */)
static bool
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);
return (EQ (val, obj)
|| EQ (sym->u.s.function, obj)
diff --git a/src/comp.c b/src/comp.c
index 64db13fc1c..9abc5d9690 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -454,6 +454,7 @@ load_gccjit_if_necessary (bool mandatory)
/* C symbols emitted for the load relocation mechanism. */
#define CURRENT_THREAD_RELOC_SYM "current_thread_reloc"
+#define F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM "f_symbols_with_pos_enabled_reloc"
#define PURE_RELOC_SYM "pure_reloc"
#define DATA_RELOC_SYM "d_reloc"
#define DATA_RELOC_IMPURE_SYM "d_reloc_imp"
@@ -542,6 +543,7 @@ typedef struct {
gcc_jit_type *emacs_int_type;
gcc_jit_type *emacs_uint_type;
gcc_jit_type *void_ptr_type;
+ gcc_jit_type *bool_ptr_type;
gcc_jit_type *char_ptr_type;
gcc_jit_type *ptrdiff_type;
gcc_jit_type *uintptr_type;
@@ -563,6 +565,16 @@ typedef struct {
gcc_jit_field *lisp_cons_u_s_u_cdr;
gcc_jit_type *lisp_cons_type;
gcc_jit_type *lisp_cons_ptr_type;
+ /* struct Lisp_Symbol_With_Position */
+ gcc_jit_rvalue *f_symbols_with_pos_enabled_ref;
+ gcc_jit_struct *lisp_symbol_with_position;
+ gcc_jit_field *lisp_symbol_with_position_header;
+ gcc_jit_field *lisp_symbol_with_position_sym;
+ gcc_jit_field *lisp_symbol_with_position_pos;
+ gcc_jit_type *lisp_symbol_with_position_type;
+ gcc_jit_type *lisp_symbol_with_position_ptr_type;
+ gcc_jit_function *get_symbol_with_position;
+ gcc_jit_function *symbol_with_pos_sym;
/* struct jmp_buf. */
gcc_jit_struct *jmp_buf_s;
/* struct handler. */
@@ -655,7 +667,10 @@ Lisp_Object helper_temp_output_buffer_setup (Lisp_Object
x);
Lisp_Object helper_unbind_n (Lisp_Object n);
void helper_save_restriction (void);
bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code);
+struct Lisp_Symbol_With_Pos *helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a);
+/* Note: helper_link_table must match the list created by
+ `declare_runtime_imported_funcs'. */
void *helper_link_table[] =
{ wrong_type_argument,
helper_PSEUDOVECTOR_TYPEP_XUNTAG,
@@ -664,6 +679,7 @@ void *helper_link_table[] =
record_unwind_protect_excursion,
helper_unbind_n,
helper_save_restriction,
+ helper_GET_SYMBOL_WITH_POSITION,
record_unwind_current_buffer,
set_internal,
helper_unwind_protect,
@@ -1328,9 +1344,9 @@ emit_XCONS (gcc_jit_rvalue *a)
}
static gcc_jit_rvalue *
-emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
+emit_BASE_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
{
- emit_comment ("EQ");
+ emit_comment ("BASE_EQ");
return gcc_jit_context_new_comparison (
comp.ctxt,
@@ -1340,6 +1356,30 @@ emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
emit_XLI (y));
}
+static gcc_jit_rvalue *
+emit_AND (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
+{
+ return gcc_jit_context_new_binary_op (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_BINARY_OP_LOGICAL_AND,
+ comp.bool_type,
+ x,
+ y);
+}
+
+static gcc_jit_rvalue *
+emit_OR (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
+{
+ return gcc_jit_context_new_binary_op (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_BINARY_OP_LOGICAL_OR,
+ comp.bool_type,
+ x,
+ y);
+}
+
static gcc_jit_rvalue *
emit_TAGGEDP (gcc_jit_rvalue *obj, Lisp_Word_tag tag)
{
@@ -1401,6 +1441,85 @@ emit_CONSP (gcc_jit_rvalue *obj)
return emit_TAGGEDP (obj, Lisp_Cons);
}
+static gcc_jit_rvalue *
+emit_BARE_SYMBOL_P (gcc_jit_rvalue *obj)
+{
+ emit_comment ("BARE_SYMBOL_P");
+
+ return gcc_jit_context_new_cast (comp.ctxt,
+ NULL,
+ emit_TAGGEDP (obj, Lisp_Symbol),
+ comp.bool_type);
+}
+
+static gcc_jit_rvalue *
+emit_SYMBOL_WITH_POS_P (gcc_jit_rvalue *obj)
+{
+ emit_comment ("SYMBOL_WITH_POS_P");
+
+ gcc_jit_rvalue *args[] =
+ { obj,
+ gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+ comp.int_type,
+ PVEC_SYMBOL_WITH_POS)
+ };
+
+ return gcc_jit_context_new_call (comp.ctxt,
+ NULL,
+ comp.pseudovectorp,
+ 2,
+ args);
+}
+
+static gcc_jit_rvalue *
+emit_SYMBOL_WITH_POS_SYM (gcc_jit_rvalue *obj)
+{
+ emit_comment ("SYMBOL_WITH_POS_SYM");
+
+ gcc_jit_rvalue *arg [] = { obj };
+ return gcc_jit_context_new_call (comp.ctxt,
+ NULL,
+ comp.symbol_with_pos_sym,
+ 1,
+ arg);
+}
+
+static gcc_jit_rvalue *
+emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
+{
+ return
+ emit_OR (
+ gcc_jit_context_new_comparison (
+ comp.ctxt, NULL,
+ GCC_JIT_COMPARISON_EQ,
+ emit_XLI (x), emit_XLI (y)),
+ emit_AND (
+ gcc_jit_lvalue_as_rvalue (
+ gcc_jit_rvalue_dereference (comp.f_symbols_with_pos_enabled_ref,
+ NULL)),
+ emit_OR (
+ emit_AND (
+ emit_SYMBOL_WITH_POS_P (x),
+ emit_OR (
+ emit_AND (
+ emit_SYMBOL_WITH_POS_P (y),
+ emit_BASE_EQ (
+ emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)),
+ emit_XLI (emit_SYMBOL_WITH_POS_SYM (y)))),
+ emit_AND (
+ emit_BARE_SYMBOL_P (y),
+ emit_BASE_EQ (
+ emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)),
+ emit_XLI (y))))),
+ emit_AND (
+ emit_BARE_SYMBOL_P (x),
+ emit_AND (
+ emit_SYMBOL_WITH_POS_P (y),
+ emit_BASE_EQ (
+ emit_XLI (x),
+ emit_XLI (emit_SYMBOL_WITH_POS_SYM (y))))))));
+}
+
static gcc_jit_rvalue *
emit_FLOATP (gcc_jit_rvalue *obj)
{
@@ -1615,7 +1734,7 @@ static gcc_jit_rvalue *
emit_NILP (gcc_jit_rvalue *x)
{
emit_comment ("NILP");
- return emit_EQ (x, emit_lisp_obj_rval (Qnil));
+ return emit_BASE_EQ (x, emit_lisp_obj_rval (Qnil));
}
static gcc_jit_rvalue *
@@ -1731,6 +1850,29 @@ emit_CHECK_CONS (gcc_jit_rvalue *x)
args));
}
+static void
+emit_CHECK_SYMBOL_WITH_POS (gcc_jit_rvalue *x)
+{
+ emit_comment ("CHECK_SYMBOL_WITH_POS");
+
+ gcc_jit_rvalue *args[] =
+ { gcc_jit_context_new_cast (comp.ctxt,
+ NULL,
+ emit_SYMBOL_WITH_POS_P (x),
+ comp.int_type),
+ emit_lisp_obj_rval (Qsymbol_with_pos_p),
+ x };
+
+ gcc_jit_block_add_eval (
+ comp.block,
+ NULL,
+ gcc_jit_context_new_call (comp.ctxt,
+ NULL,
+ comp.check_type,
+ 3,
+ args));
+}
+
static gcc_jit_rvalue *
emit_car_addr (gcc_jit_rvalue *c)
{
@@ -2095,7 +2237,13 @@ emit_limple_insn (Lisp_Object insn)
gcc_jit_block *target1 = retrive_block (arg[2]);
gcc_jit_block *target2 = retrive_block (arg[3]);
- emit_cond_jump (emit_EQ (a, b), target1, target2);
+ if ((CALL1I (comp-cstr-imm-vld-p, arg[0])
+ && NILP (CALL1I (comp-cstr-imm, arg[0])))
+ || (CALL1I (comp-cstr-imm-vld-p, arg[1])
+ && NILP (CALL1I (comp-cstr-imm, arg[1]))))
+ emit_cond_jump (emit_BASE_EQ (a, b), target1, target2);
+ else
+ emit_cond_jump (emit_EQ (a, b), target1, target2);
}
else if (EQ (op, Qcond_jump_narg_leq))
{
@@ -2714,7 +2862,8 @@ declare_imported_data (void)
/*
Declare as imported all the functions that are requested from the runtime.
- These are either subrs or not.
+ These are either subrs or not. Note that the list created here must match
+ the array `helper_link_table'.
*/
static Lisp_Object
declare_runtime_imported_funcs (void)
@@ -2751,6 +2900,10 @@ declare_runtime_imported_funcs (void)
ADD_IMPORTED (helper_save_restriction, comp.void_type, 0, NULL);
+ args[0] = comp.lisp_obj_type;
+ ADD_IMPORTED (helper_GET_SYMBOL_WITH_POSITION,
comp.lisp_symbol_with_position_ptr_type,
+ 1, args);
+
ADD_IMPORTED (record_unwind_current_buffer, comp.void_type, 0, NULL);
args[0] = args[1] = args[2] = comp.lisp_obj_type;
@@ -2798,6 +2951,15 @@ emit_ctxt_code (void)
gcc_jit_type_get_pointer (comp.thread_state_ptr_type),
CURRENT_THREAD_RELOC_SYM));
+ comp.f_symbols_with_pos_enabled_ref =
+ gcc_jit_lvalue_as_rvalue (
+ gcc_jit_context_new_global (
+ comp.ctxt,
+ NULL,
+ GCC_JIT_GLOBAL_EXPORTED,
+ comp.bool_ptr_type,
+ F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM));
+
comp.pure_ptr =
gcc_jit_lvalue_as_rvalue (
gcc_jit_context_new_global (
@@ -2977,6 +3139,39 @@ define_lisp_cons (void)
}
+static void
+define_lisp_symbol_with_position (void)
+{
+ comp.lisp_symbol_with_position_header =
+ gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ comp.ptrdiff_type,
+ "header");
+ comp.lisp_symbol_with_position_sym =
+ gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "sym");
+ comp.lisp_symbol_with_position_pos =
+ gcc_jit_context_new_field (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "pos");
+ gcc_jit_field *fields [3] = {comp.lisp_symbol_with_position_header,
+ comp.lisp_symbol_with_position_sym,
+ comp.lisp_symbol_with_position_pos};
+ comp.lisp_symbol_with_position =
+ gcc_jit_context_new_struct_type (comp.ctxt,
+ NULL,
+ "comp_lisp_symbol_with_position",
+ 3,
+ fields);
+ comp.lisp_symbol_with_position_type =
+ gcc_jit_struct_as_type (comp.lisp_symbol_with_position);
+ comp.lisp_symbol_with_position_ptr_type =
+ gcc_jit_type_get_pointer (comp.lisp_symbol_with_position_type);
+}
+
/* Opaque jmp_buf definition. */
static void
@@ -3672,6 +3867,82 @@ define_PSEUDOVECTORP (void)
comp.bool_type, 2, args, false));
}
+static void
+define_GET_SYMBOL_WITH_POSITION (void)
+{
+ gcc_jit_param *param[] =
+ { gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "a") };
+
+ comp.get_symbol_with_position =
+ gcc_jit_context_new_function (comp.ctxt, NULL,
+ GCC_JIT_FUNCTION_INTERNAL,
+ comp.lisp_symbol_with_position_ptr_type,
+ "GET_SYMBOL_WITH_POSITION",
+ 1,
+ param,
+ 0);
+
+ DECL_BLOCK (entry_block, comp.get_symbol_with_position);
+
+ comp.block = entry_block;
+ comp.func = comp.get_symbol_with_position;
+
+ gcc_jit_rvalue *args[] =
+ { gcc_jit_param_as_rvalue (param[0]) };
+ /* FIXME use XUNTAG now that's available. */
+ gcc_jit_block_end_with_return (
+ entry_block,
+ NULL,
+ emit_call (intern_c_string ("helper_GET_SYMBOL_WITH_POSITION"),
+ comp.lisp_symbol_with_position_ptr_type,
+ 1, args, false));
+}
+
+static void define_SYMBOL_WITH_POS_SYM (void)
+{
+ gcc_jit_rvalue *tmpr, *swp;
+ gcc_jit_lvalue *tmpl;
+
+ gcc_jit_param *param [] =
+ { gcc_jit_context_new_param (comp.ctxt,
+ NULL,
+ comp.lisp_obj_type,
+ "a") };
+ comp.symbol_with_pos_sym =
+ gcc_jit_context_new_function (comp.ctxt, NULL,
+ GCC_JIT_FUNCTION_INTERNAL,
+ comp.lisp_obj_type,
+ "SYMBOL_WITH_POS_SYM",
+ 1,
+ param,
+ 0);
+
+ DECL_BLOCK (entry_block, comp.symbol_with_pos_sym);
+ comp.func = comp.symbol_with_pos_sym;
+ comp.block = entry_block;
+
+ emit_CHECK_SYMBOL_WITH_POS (gcc_jit_param_as_rvalue (param [0]));
+
+ gcc_jit_rvalue *args[] = { gcc_jit_param_as_rvalue (param [0]) };
+
+ swp = gcc_jit_context_new_call (comp.ctxt,
+ NULL,
+ comp.get_symbol_with_position,
+ 1,
+ args);
+ tmpl = gcc_jit_rvalue_dereference (swp, NULL);
+ tmpr = gcc_jit_lvalue_as_rvalue (tmpl);
+ gcc_jit_block_end_with_return (entry_block,
+ NULL,
+ gcc_jit_rvalue_access_field (
+ tmpr,
+ NULL,
+ comp.lisp_symbol_with_position_sym));
+}
+
static void
define_CHECK_IMPURE (void)
{
@@ -4309,6 +4580,7 @@ Return t on success. */)
gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG_LONG);
comp.unsigned_long_long_type =
gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG);
+ comp.bool_ptr_type = gcc_jit_type_get_pointer (comp.bool_type);
comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type);
comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt,
sizeof (EMACS_INT),
@@ -4381,6 +4653,7 @@ Return t on success. */)
/* Define data structures. */
define_lisp_cons ();
+ define_lisp_symbol_with_position ();
define_jmp_buf ();
define_handler_struct ();
define_thread_state_struct ();
@@ -4602,7 +4875,9 @@ DEFUN ("comp--compile-ctxt-to-file",
Fcomp__compile_ctxt_to_file,
/* Define inline functions. */
define_CAR_CDR ();
define_PSEUDOVECTORP ();
+ define_GET_SYMBOL_WITH_POSITION ();
define_CHECK_TYPE ();
+ define_SYMBOL_WITH_POS_SYM ();
define_CHECK_IMPURE ();
define_bool_to_lisp_obj ();
define_setcar_setcdr ();
@@ -4734,6 +5009,14 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum
pvec_type code)
code);
}
+struct Lisp_Symbol_With_Pos *
+helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a)
+{
+ if (!SYMBOL_WITH_POS_P (a))
+ wrong_type_argument (Qwrong_type_argument, a);
+ return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos);
+}
+
/* `native-comp-eln-load-path' clean-up support code. */
@@ -5000,12 +5283,15 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u,
bool loading_dump,
{
struct thread_state ***current_thread_reloc =
dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM);
+ bool **f_symbols_with_pos_enabled_reloc =
+ dynlib_sym (handle, F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM);
void **pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM);
Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM);
Lisp_Object *data_imp_relocs = comp_u->data_imp_relocs;
void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM);
if (!(current_thread_reloc
+ && f_symbols_with_pos_enabled_reloc
&& pure_reloc
&& data_relocs
&& data_imp_relocs
@@ -5017,6 +5303,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u,
bool loading_dump,
xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file);
*current_thread_reloc = ¤t_thread;
+ *f_symbols_with_pos_enabled_reloc = &symbols_with_pos_enabled;
*pure_reloc = pure;
/* Imported functions. */
@@ -5386,6 +5673,7 @@ compiled one. */);
DEFSYM (Qnumberp, "numberp");
DEFSYM (Qintegerp, "integerp");
DEFSYM (Qcomp_maybe_gc_or_quit, "comp-maybe-gc-or-quit");
+ DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p");
/* Allocation classes. */
DEFSYM (Qd_default, "d-default");
@@ -5536,3 +5824,6 @@ be preloaded. */);
defsubr (&Snative_comp_available_p);
}
+/* Local Variables: */
+/* c-file-offsets: ((arglist-intro . +)) */
+/* End: */
diff --git a/src/data.c b/src/data.c
index f287c38fcd..7422348e39 100644
--- a/src/data.c
+++ b/src/data.c
@@ -216,6 +216,7 @@ for example, (type-of 1) returns `integer'. */)
case PVEC_NORMAL_VECTOR: return Qvector;
case PVEC_BIGNUM: return Qinteger;
case PVEC_MARKER: return Qmarker;
+ case PVEC_SYMBOL_WITH_POS: return Qsymbol_with_pos;
case PVEC_OVERLAY: return Qoverlay;
case PVEC_FINALIZER: return Qfinalizer;
case PVEC_USER_PTR: return Quser_ptr;
@@ -318,6 +319,26 @@ DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0,
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,
doc: /* Return t if OBJECT is a symbol. */
attributes: const)
@@ -755,6 +776,62 @@ DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
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 ("remove-pos-from-symbol", Fremove_pos_from_symbol,
+ Sremove_pos_from_symbol, 1, 1, 0,
+ doc: /* If ARG is a symbol with position, return it without the
position.
+Otherwise, return ARG unchanged. Compare with `bare-symbol'. */)
+ (register Lisp_Object arg)
+{
+ if (SYMBOL_WITH_POS_P (arg))
+ return (SYMBOL_WITH_POS_SYM (arg));
+ return arg;
+}
+
+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,
doc: /* Set SYMBOL's function definition to DEFINITION, and return
DEFINITION. */)
(register Lisp_Object symbol, Lisp_Object definition)
@@ -3892,7 +3969,7 @@ A is a bool vector, B is t or nil, and I is an index into
A. */)
void
syms_of_data (void)
{
- Lisp_Object error_tail, arith_tail;
+ Lisp_Object error_tail, arith_tail, recursion_tail;
DEFSYM (Qquote, "quote");
DEFSYM (Qlambda, "lambda");
@@ -3927,8 +4004,14 @@ syms_of_data (void)
DEFSYM (Qmark_inactive, "mark-inactive");
DEFSYM (Qinhibited_interaction, "inhibited-interaction");
+ DEFSYM (Qrecursion_error, "recursion-error");
+ DEFSYM (Qexcessive_variable_binding, "excessive-variable-binding");
+ DEFSYM (Qexcessive_lisp_nesting, "excessive-lisp-nesting");
+
DEFSYM (Qlistp, "listp");
DEFSYM (Qconsp, "consp");
+ DEFSYM (Qbare_symbol_p, "bare-symbol-p");
+ DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p");
DEFSYM (Qsymbolp, "symbolp");
DEFSYM (Qfixnump, "fixnump");
DEFSYM (Qintegerp, "integerp");
@@ -3954,6 +4037,7 @@ syms_of_data (void)
DEFSYM (Qchar_table_p, "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 (Qunevalled, "unevalled");
@@ -4032,12 +4116,23 @@ syms_of_data (void)
PUT_ERROR (Qunderflow_error, Fcons (Qrange_error, arith_tail),
"Arithmetic underflow error");
+ recursion_tail = pure_cons (Qrecursion_error, error_tail);
+ Fput (Qrecursion_error, Qerror_conditions, recursion_tail);
+ Fput (Qrecursion_error, Qerror_message, build_pure_c_string
+ ("Excessive recursive calling error"));
+
+ PUT_ERROR (Qexcessive_variable_binding, recursion_tail,
+ "Variable binding depth exceeds max-specpdl-size");
+ PUT_ERROR (Qexcessive_lisp_nesting, recursion_tail,
+ "Lisp nesting exceeds `max-lisp-eval-depth'");
+
/* Types that type-of returns. */
DEFSYM (Qinteger, "integer");
DEFSYM (Qsymbol, "symbol");
DEFSYM (Qstring, "string");
DEFSYM (Qcons, "cons");
DEFSYM (Qmarker, "marker");
+ DEFSYM (Qsymbol_with_pos, "symbol-with-pos");
DEFSYM (Qoverlay, "overlay");
DEFSYM (Qfinalizer, "finalizer");
DEFSYM (Qmodule_function, "module-function");
@@ -4089,6 +4184,8 @@ syms_of_data (void)
defsubr (&Snumber_or_marker_p);
defsubr (&Sfloatp);
defsubr (&Snatnump);
+ defsubr (&Sbare_symbol_p);
+ defsubr (&Ssymbol_with_pos_p);
defsubr (&Ssymbolp);
defsubr (&Skeywordp);
defsubr (&Sstringp);
@@ -4119,6 +4216,10 @@ syms_of_data (void)
defsubr (&Sindirect_function);
defsubr (&Ssymbol_plist);
defsubr (&Ssymbol_name);
+ defsubr (&Sbare_symbol);
+ defsubr (&Ssymbol_with_pos_pos);
+ defsubr (&Sremove_pos_from_symbol);
+ defsubr (&Sposition_symbol);
defsubr (&Smakunbound);
defsubr (&Sfmakunbound);
defsubr (&Sboundp);
@@ -4201,6 +4302,12 @@ This variable cannot be set; trying to do so will signal
an error. */);
Vmost_negative_fixnum = make_fixnum (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 (Qmakunbound, "makunbound");
DEFSYM (Qunlet, "unlet");
diff --git a/src/eval.c b/src/eval.c
index 5514583b6a..6a8c759c1d 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -2395,8 +2395,7 @@ grow_specpdl (void)
if (max_specpdl_size < 400)
max_size = max_specpdl_size = 400;
if (max_size <= specpdl_size)
- signal_error ("Variable binding depth exceeds max-specpdl-size",
- Qnil);
+ xsignal0 (Qexcessive_variable_binding);
}
pdlvec = xpalloc (pdlvec, &pdlvecsize, 1, max_size + 1, sizeof *specpdl);
specpdl = pdlvec + 1;
@@ -2450,7 +2449,7 @@ eval_sub (Lisp_Object form)
if (max_lisp_eval_depth < 100)
max_lisp_eval_depth = 100;
if (lisp_eval_depth > max_lisp_eval_depth)
- error ("Lisp nesting exceeds `max-lisp-eval-depth'");
+ xsignal0 (Qexcessive_lisp_nesting);
}
Lisp_Object original_fun = XCAR (form);
@@ -3054,7 +3053,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
if (max_lisp_eval_depth < 100)
max_lisp_eval_depth = 100;
if (lisp_eval_depth > max_lisp_eval_depth)
- error ("Lisp nesting exceeds `max-lisp-eval-depth'");
+ xsignal0 (Qexcessive_lisp_nesting);
}
count = record_in_backtrace (args[0], &args[1], nargs - 1);
diff --git a/src/fns.c b/src/fns.c
index 7b9142d471..ade30fca41 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -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))
return true;
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;
- 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)
*hash = hash_code;
diff --git a/src/keyboard.c b/src/keyboard.c
index 70e055a9df..441c23e10c 100644
--- a/src/keyboard.c
+++ b/src/keyboard.c
@@ -689,6 +689,8 @@ recursive_edit_1 (void)
{
specbind (Qstandard_output, Qt);
specbind (Qstandard_input, Qt);
+ specbind (Qsymbols_with_pos_enabled, Qnil);
+ specbind (Qprint_symbols_bare, Qnil);
}
#ifdef HAVE_WINDOW_SYSTEM
diff --git a/src/lisp.h b/src/lisp.h
index c5e63110c7..97ed084ce8 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -353,18 +353,38 @@ typedef EMACS_INT Lisp_Word;
# 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_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x)
#define lisp_h_CHECK_TYPE(ok, predicate, x) \
((ok) ? (void) 0 : wrong_type_argument (predicate, x))
#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)) \
+ ? XLI (XSYMBOL_WITH_POS((x))->sym) == XLI (y) \
+ : SYMBOL_WITH_POS_P((y)) \
+ && (XLI (XSYMBOL_WITH_POS((x))->sym) \
+ == XLI (XSYMBOL_WITH_POS((y))->sym)) \
+ : (SYMBOL_WITH_POS_P ((y)) \
+ && BARE_SYMBOL_P ((x)) \
+ && (XLI (x) == XLI ((XSYMBOL_WITH_POS ((y)))->sym))))))
+
#define lisp_h_FIXNUMP(x) \
(! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \
- (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) \
& ((1 << INTTYPEBITS) - 1)))
#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) \
(eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), \
(sym)->u.s.val.value = (v))
@@ -373,7 +393,10 @@ typedef EMACS_INT Lisp_Word;
#define lisp_h_SYMBOL_TRAPPED_WRITE_P(sym) (XSYMBOL (sym)->u.s.trapped_write)
#define lisp_h_SYMBOL_VAL(sym) \
(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) \
(! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \
- (unsigned) (tag)) \
@@ -418,11 +441,12 @@ typedef EMACS_INT Lisp_Word;
# define XLI(o) lisp_h_XLI (o)
# define XIL(i) lisp_h_XIL (i)
# 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_SYMBOL(x) lisp_h_CHECK_SYMBOL (x)
# define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, 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 FIXNUMP(x) lisp_h_FIXNUMP (x)
# define NILP(x) lisp_h_NILP (x)
@@ -430,7 +454,7 @@ typedef EMACS_INT Lisp_Word;
# 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_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 VECTORLIKEP(x) lisp_h_VECTORLIKEP (x)
# define XCAR(c) lisp_h_XCAR (c)
@@ -589,6 +613,7 @@ extern Lisp_Object char_table_ref (Lisp_Object, int)
ATTRIBUTE_PURE;
extern void char_table_set (Lisp_Object, int, Lisp_Object);
/* 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 wrong_type_argument (Lisp_Object, Lisp_Object);
extern Lisp_Object default_value (Lisp_Object symbol);
@@ -973,57 +998,12 @@ union vectorlike_header
ptrdiff_t size;
};
-INLINE bool
-(SYMBOLP) (Lisp_Object x)
-{
- return lisp_h_SYMBOLP (x);
-}
-
-INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED
-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)
+struct Lisp_Symbol_With_Pos
{
- 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);
-}
+ union vectorlike_header header;
+ Lisp_Object sym; /* A symbol */
+ Lisp_Object pos; /* A fixnum */
+} GCALIGNED_STRUCT;
/* In the size word of a vector, this bit means the vector has been marked. */
@@ -1048,6 +1028,7 @@ enum pvec_type
PVEC_MARKER,
PVEC_OVERLAY,
PVEC_FINALIZER,
+ PVEC_SYMBOL_WITH_POS,
PVEC_MISC_PTR,
PVEC_USER_PTR,
PVEC_PROCESS,
@@ -1107,6 +1088,92 @@ enum More_Lisp_Bits
values. They are macros for use in #if and static initializers. */
#define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS)
#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. */
@@ -1238,7 +1305,14 @@ make_fixed_natnum (EMACS_INT n)
}
/* 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
(EQ) (Lisp_Object x, Lisp_Object y)
{
@@ -1704,21 +1778,6 @@ PSEUDOVECTOR_TYPEP (const union vectorlike_header *a,
enum pvec_type code)
== (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. */
struct Lisp_Bool_Vector
@@ -2630,6 +2689,22 @@ XOVERLAY (Lisp_Object a)
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
USER_PTRP (Lisp_Object x)
{
@@ -4061,6 +4136,7 @@ extern bool gc_in_progress;
extern Lisp_Object make_float (double);
extern void display_malloc_warning (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 void free_cons (struct Lisp_Cons *);
extern void init_alloc_once (void);
diff --git a/src/lread.c b/src/lread.c
index a0af98fa0f..77b5b65e10 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -128,9 +128,8 @@ static ptrdiff_t read_from_string_index;
static ptrdiff_t read_from_string_index_byte;
static ptrdiff_t read_from_string_limit;
-/* Number of characters read in the current call to Fread or
- Fread_from_string. */
-static EMACS_INT readchar_count;
+/* Position in object from which characters are being read by `readchar'. */
+static EMACS_INT readchar_offset;
/* This contains the last string skipped with #@. */
static char *saved_doc_string;
@@ -213,7 +212,7 @@ readchar (Lisp_Object readcharfun, bool *multibyte)
if (multibyte)
*multibyte = 0;
- readchar_count++;
+ readchar_offset++;
if (BUFFERP (readcharfun))
{
@@ -424,7 +423,7 @@ skip_dyn_eof (Lisp_Object readcharfun)
static void
unreadchar (Lisp_Object readcharfun, int c)
{
- readchar_count--;
+ readchar_offset--;
if (c == -1)
/* Don't back up the pointer if we're unreading the end-of-input mark,
since readchar didn't advance it when we read it. */
@@ -647,12 +646,12 @@ struct subst
};
static Lisp_Object read_internal_start (Lisp_Object, Lisp_Object,
- Lisp_Object);
-static Lisp_Object read0 (Lisp_Object);
-static Lisp_Object read1 (Lisp_Object, int *, bool);
+ Lisp_Object, bool);
+static Lisp_Object read0 (Lisp_Object, bool);
+static Lisp_Object read1 (Lisp_Object, int *, bool, bool);
-static Lisp_Object read_list (bool, Lisp_Object);
-static Lisp_Object read_vector (Lisp_Object, bool);
+static Lisp_Object read_list (bool, Lisp_Object, bool);
+static Lisp_Object read_vector (Lisp_Object, bool, bool);
static Lisp_Object substitute_object_recurse (struct subst *, Lisp_Object);
static void substitute_in_interval (INTERVAL, void *);
@@ -2287,7 +2286,7 @@ readevalloop (Lisp_Object readcharfun,
Qnil, false);
if (!NILP (Vpurify_flag) && c == '(')
{
- val = read_list (0, readcharfun);
+ val = read_list (0, readcharfun, false);
}
else
{
@@ -2309,7 +2308,7 @@ readevalloop (Lisp_Object readcharfun,
else if (! NILP (Vload_read_function))
val = call1 (Vload_read_function, readcharfun);
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. */
if (HASH_TABLE_P (read_objects_map)
@@ -2467,7 +2466,35 @@ STREAM or the value of `standard-input' may be:
return call1 (intern ("read-minibuffer"),
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,
@@ -2483,18 +2510,21 @@ the end of STRING. */)
Lisp_Object ret;
CHECK_STRING (string);
/* `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));
}
/* 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
-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;
- readchar_count = 0;
+ readchar_offset = BUFFERP (stream) ? XBUFFER (stream)->pt : 0;
/* We can get called from readevalloop which may have set these
already. */
if (! HASH_TABLE_P (read_objects_map)
@@ -2530,7 +2560,7 @@ read_internal_start (Lisp_Object stream, Lisp_Object
start, Lisp_Object end)
read_from_string_limit = endval;
}
- retval = read0 (stream);
+ retval = read0 (stream, locate_syms);
if (EQ (Vread_with_symbol_positions, Qt)
|| EQ (Vread_with_symbol_positions, stream))
Vread_symbol_positions_list = Fnreverse (Vread_symbol_positions_list);
@@ -2549,12 +2579,12 @@ read_internal_start (Lisp_Object stream, Lisp_Object
start, Lisp_Object end)
are not allowed. */
static Lisp_Object
-read0 (Lisp_Object readcharfun)
+read0 (Lisp_Object readcharfun, bool locate_syms)
{
register Lisp_Object val;
int c;
- val = read1 (readcharfun, &c, 0);
+ val = read1 (readcharfun, &c, 0, locate_syms);
if (!c)
return val;
@@ -2978,10 +3008,12 @@ read_integer (Lisp_Object readcharfun, int radix,
in *PCH and the return value is not interesting. Else, we store
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
-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;
bool uninterned_symbol = false;
@@ -3001,10 +3033,10 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
switch (c)
{
case '(':
- return read_list (0, readcharfun);
+ return read_list (0, readcharfun, locate_syms);
case '[':
- return read_vector (readcharfun, 0);
+ return read_vector (readcharfun, 0, locate_syms);
case ')':
case ']':
@@ -3023,7 +3055,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
/* Accept extended format for hash tables (extensible to
other types), e.g.
#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 data = Qnil;
Lisp_Object val = Qnil;
@@ -3112,7 +3144,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
if (c == '[')
{
Lisp_Object tmp;
- tmp = read_vector (readcharfun, 0);
+ tmp = read_vector (readcharfun, 0, false);
if (ASIZE (tmp) < CHAR_TABLE_STANDARD_SLOTS)
error ("Invalid size char-table");
XSETPVECTYPE (XVECTOR (tmp), PVEC_CHAR_TABLE);
@@ -3125,7 +3157,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
{
/* Sub char-table can't be read as a regular
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);
int i, depth, min_char;
struct Lisp_Cons *cell;
@@ -3163,7 +3195,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
if (c == '&')
{
Lisp_Object length;
- length = read1 (readcharfun, pch, first_in_list);
+ length = read1 (readcharfun, pch, first_in_list, false);
c = READCHAR;
if (c == '"')
{
@@ -3172,7 +3204,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
unsigned char *data;
UNREAD (c);
- tmp = read1 (readcharfun, pch, first_in_list);
+ tmp = read1 (readcharfun, pch, first_in_list, false);
if (STRING_MULTIBYTE (tmp)
|| (size_in_chars != SCHARS (tmp)
/* We used to print 1 char too many
@@ -3200,7 +3232,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
build them using function calls. */
Lisp_Object tmp;
struct Lisp_Vector *vec;
- tmp = read_vector (readcharfun, 1);
+ tmp = read_vector (readcharfun, 1, false);
vec = XVECTOR (tmp);
if (! (COMPILED_STACK_DEPTH < ASIZE (tmp)
&& (FIXNUMP (AREF (tmp, COMPILED_ARGLIST))
@@ -3233,7 +3265,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
int ch;
/* Read the string itself. */
- tmp = read1 (readcharfun, &ch, 0);
+ tmp = read1 (readcharfun, &ch, 0, false);
if (ch != 0 || !STRINGP (tmp))
invalid_syntax ("#", readcharfun);
/* Read the intervals and their properties. */
@@ -3241,14 +3273,14 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
{
Lisp_Object beg, end, plist;
- beg = read1 (readcharfun, &ch, 0);
+ beg = read1 (readcharfun, &ch, 0, false);
end = plist = Qnil;
if (ch == ')')
break;
if (ch == 0)
- end = read1 (readcharfun, &ch, 0);
+ end = read1 (readcharfun, &ch, 0, false);
if (ch == 0)
- plist = read1 (readcharfun, &ch, 0);
+ plist = read1 (readcharfun, &ch, 0, false);
if (ch)
invalid_syntax ("Invalid string property list", readcharfun);
Fset_text_properties (beg, end, plist, tmp);
@@ -3359,7 +3391,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
if (c == '$')
return Vload_file_name;
if (c == '\'')
- return list2 (Qfunction, read0 (readcharfun));
+ return list2 (Qfunction, read0 (readcharfun, locate_syms));
/* #:foo is the uninterned symbol named foo. */
if (c == ':')
{
@@ -3442,7 +3474,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
hash_put (h, number, placeholder, hash);
/* Read the object itself. */
- Lisp_Object tem = read0 (readcharfun);
+ Lisp_Object tem = read0 (readcharfun, locate_syms);
/* If it can be recursive, remember it for
future substitutions. */
@@ -3498,6 +3530,9 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
else if (c == 'b' || c == 'B')
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);
invalid_syntax ("#", readcharfun);
@@ -3506,10 +3541,10 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
goto retry;
case '\'':
- return list2 (Qquote, read0 (readcharfun));
+ return list2 (Qquote, read0 (readcharfun, locate_syms));
case '`':
- return list2 (Qbackquote, read0 (readcharfun));
+ return list2 (Qbackquote, read0 (readcharfun, locate_syms));
case ',':
{
@@ -3525,7 +3560,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
comma_type = Qcomma;
}
- value = read0 (readcharfun);
+ value = read0 (readcharfun, locate_syms);
return list2 (comma_type, value);
}
case '?':
@@ -3727,7 +3762,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
char *p = read_buffer;
char *end = read_buffer + read_buffer_size;
bool quoted = false;
- EMACS_INT start_position = readchar_count - 1;
+ EMACS_INT start_position = readchar_offset - 1;
do
{
@@ -3832,6 +3867,11 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list)
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)
|| EQ (Vread_with_symbol_positions, readcharfun))
@@ -4090,9 +4130,9 @@ string_to_number (char const *string, int base, ptrdiff_t
*plen)
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);
Lisp_Object vector = make_nil_vector (size);
@@ -4164,10 +4204,12 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag)
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
-read_list (bool flag, Lisp_Object readcharfun)
+read_list (bool flag, Lisp_Object readcharfun, bool locate_syms)
{
Lisp_Object val, tail;
Lisp_Object elt, tem;
@@ -4185,7 +4227,7 @@ read_list (bool flag, Lisp_Object readcharfun)
while (1)
{
int ch;
- elt = read1 (readcharfun, &ch, first_in_list);
+ elt = read1 (readcharfun, &ch, first_in_list, locate_syms);
first_in_list = 0;
@@ -4211,10 +4253,10 @@ read_list (bool flag, Lisp_Object readcharfun)
if (ch == '.')
{
if (!NILP (tail))
- XSETCDR (tail, read0 (readcharfun));
+ XSETCDR (tail, read0 (readcharfun, locate_syms));
else
- val = read0 (readcharfun);
- read1 (readcharfun, &ch, 0);
+ val = read0 (readcharfun, locate_syms);
+ read1 (readcharfun, &ch, 0, locate_syms);
if (ch == ')')
{
@@ -5090,6 +5132,7 @@ void
syms_of_lread (void)
{
defsubr (&Sread);
+ defsubr (&Sread_positioning_symbols);
defsubr (&Sread_from_string);
defsubr (&Slread__substitute_object_in_subtree);
defsubr (&Sintern);
diff --git a/src/print.c b/src/print.c
index 7440a82f6f..04a271ce45 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1649,6 +1649,30 @@ print_vectorlike (Lisp_Object obj, Lisp_Object
printcharfun, bool escapeflag,
printchar ('>', printcharfun);
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:
print_c_string ("#<overlay ", printcharfun);
if (! XMARKER (OVERLAY_START (obj))->buffer)
@@ -1974,7 +1998,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun,
bool escapeflag)
error ("Apparently circular structure being printed");
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);
strout (buf, len, len, printcharfun);
@@ -2478,6 +2502,13 @@ priorities. Values other than nil or t are also treated
as
`default'. */);
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 */
staticpro (&Vprin1_to_string_buffer);