[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] scratch/accurate-warning-pos 75b18e0: Bring the scratch/ac
|
From: |
Alan Mackenzie |
|
Subject: |
[Emacs-diffs] scratch/accurate-warning-pos 75b18e0: Bring the scratch/accurate-warning-pos branch to full functionality. |
|
Date: |
Fri, 23 Nov 2018 07:41:42 -0500 (EST) |
branch: scratch/accurate-warning-pos
commit 75b18e07e57da7ee4362db800352d6650f5f7290
Author: Alan Mackenzie <address@hidden>
Commit: Alan Mackenzie <address@hidden>
Bring the scratch/accurate-warning-pos branch to full functionality.
The branch will now make bootstrap.
* src/lisp.h (lisp_h_EQ, etc.): Replace use of lisp_h_FOO by plain FOO. To
enable this, some definitions have been moved in the file.
(XBARE_SYMBOL): Renamed from XSYMBOL. Create a new XSYMBOL.
(BASE_EQ): New function.
* src/alloc.c (Fgarbage_collect): Bind symbols-with-pos-enabled to nil.
* src/data.c (Fbare_symbol): Renamed from Fsymbol_with_pos_sym. It now
accepts a bare symbol as argument.
(syms_of_data): Declare Qsymbols_with_pos_enabled as a symbol.
* src/fns.c (hash_lookup): If the key is a symbol with position, replace it
by
its bare symbol before proceding.
* src/lread.c (read1): In recursive calls to read1, and calls to other
reading
function, use an argument of false for locate_syms when symbols with
positions
are decidedly unwanted.
* src/print.c (Vprint_symbols_bare): New variable.
(print_vectorlike): Strip the position from a symbol with position before
printing it when Vprint_symbols_bare is non-nil.
* lisp/emacs-lisp/bytecomp.el (byte-compile-strip-s-p-1)
(byte-compile-strip-symbol-positions): New functions.
(byte-compile-recurse-toplevel, byte-compile-initial-macro-environment)
(byte-compile-preprocess, byte-compile-macroexpand-declare-function): Bind
print-symbols-bare to non-nil around macro
expansion.
(byte-compile-warning-prefix): Temporarily output source positions in both
old
and new methods in warning messages.
(byte-compile-warn, ...): Use symbolp in place of symbol-with-pos-p.
Replace
symbol-with-pos-sym by bare-symbol.
(byte-compile--warn-x, byte-compile-form): Replace the erroneous push by
cons
when binding
byte-compile--form-stack.
(byte-compile-file): Bind symbols-with-pos-enabled to non-nil to use the new
mechanism.
(byte-compile-toplevel-file-form): Bind and push a form onto
byte-compile--form-stack.
(byte-compile-file-form-autoload, byte-compile-file-form-defvar)
(byte-compile-file-form-eval, byte-compile-file-form-defmumble)
(byte-compile-lambda, byte-compile-form, byte-compile-dynamic-variable-op)
(byte-compile-constant, byte-compile-cond-jump-table): Strip positions from
symbols before compiling.
* lisp/emacs-lisp/cconv.el (cconv-convert, cconv--analyze-use)
(cconv--analyze-function, cconv-analyze-form): Replace calls to
byte-compile-warn with byte-compile--warn-x.
* lisp/emacs-lisp/macroexp.el (macroexp--warn-and-return): Add an extra
parameter, using it to call byte-compile--warn-x in place of
byte-compile-warn.
(macroexp-macroexpand, macroexp--expand-all): Add extra argument to call of
macroexp--warn-and-return.
* lisp/emacs-lisp/cl-macs.el (cl-macs--strip-s-p-1)
(cl-macs--strip-symbol-positions): New functions. These are duplicates of
new functions in bytecomp.el, written to facilitate bootstrap, but this
duplication must be resolved somehow.
(cl-defstruct): Strip positions from symbols.
* lisp/emacs-lisp/cl-generic.el (cl-defmethod)
* lisp/emacs-lisp/cl-macs.el (cl-symbol-macrolet, cl-defstruct)
* lisp/emacs-lisp/eieio-core.el (eieio-oref)
* lisp/emacs-lisp/eieio.el (defclass)
* lisp/emacs-lisp/gv.el (gv-ref)
* lisp/emacs-lisp/pcase.el (pcase--u1): Add extra position arguments to the
calls of macroexp--warn-and-return.
---
lisp/emacs-lisp/bytecomp.el | 182 ++++++++++++++++++++++++++++--------------
lisp/emacs-lisp/cconv.el | 21 ++---
lisp/emacs-lisp/cl-generic.el | 4 +-
lisp/emacs-lisp/cl-macs.el | 45 +++++++++--
lisp/emacs-lisp/eieio-core.el | 1 +
lisp/emacs-lisp/eieio.el | 1 +
lisp/emacs-lisp/gv.el | 5 +-
lisp/emacs-lisp/macroexp.el | 7 +-
lisp/emacs-lisp/pcase.el | 1 +
src/alloc.c | 5 +-
src/data.c | 13 +--
src/fns.c | 2 +
src/lisp.h | 85 ++++++++++++--------
src/lread.c | 18 ++---
src/print.c | 29 ++++---
15 files changed, 286 insertions(+), 133 deletions(-)
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 891f3fd..cad9912 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -453,6 +453,36 @@ This is used by the warning message routines to determine a
source code position. The most accessible element is the current
most deeply nested form.")
+(defun byte-compile-strip-s-p-1 (arg)
+ "Strip all positions from symbols with position in ARG, destructively
modifying ARG
+Return the modified ARG."
+ (cond
+ ((symbolp arg)
+ (bare-symbol arg))
+ ((consp arg)
+ (let ((a arg))
+ (while (consp (cdr a))
+ (setcar a (byte-compile-strip-s-p-1 (car a)))
+ (setq a (cdr a)))
+ (setcar a (byte-compile-strip-s-p-1 (car a)))
+ ;; (if (cdr a)
+ (unless (bare-symbol-p (cdr a)) ; includes (unpositioned) nil.
+ (setcdr a (byte-compile-strip-s-p-1 (cdr a)))))
+ arg)
+ ((vectorp arg)
+ (let ((i 0)
+ (len (length arg)))
+ (while (< i len)
+ (aset arg i (byte-compile-strip-s-p-1 (aref arg i)))
+ (setq i (1+ i))))
+ arg)
+ (t arg)))
+
+(defun byte-compile-strip-symbol-positions (arg)
+ "Strip all positions from symbols (recursively) in ARG. Don't modify ARG."
+ (let ((arg1 (copy-tree arg t)))
+ (byte-compile-strip-s-p-1 arg1)))
+
(defun byte-compile-recurse-toplevel (form non-toplevel-case)
"Implement `eval-when-compile' and `eval-and-compile'.
Return the compile-time value of FORM."
@@ -461,7 +491,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)
@@ -502,7 +533,8 @@ Return the compile-time value of FORM."
;; Don't compile here, since we don't know
;; whether to compile as byte-compile-form
;; or byte-compile-file-form.
- (let ((expanded
+ (let* ((print-symbols-bare t)
+ (expanded
(macroexpand-all
form
macroexpand-all-environment)))
@@ -1167,19 +1199,31 @@ Return nil if such is not found."
(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 (if symbols-with-pos-enabled
- (+ byte-compile-read-position
offset)
- byte-compile-last-position)
- )
- (1+ (count-lines (point-min) (point-at-bol))))
- (save-excursion
- (goto-char (if symbols-with-pos-enabled
- (+ byte-compile-read-position
offset)
- byte-compile-last-position)
- )
- (1+ (current-column)))))
+ ;; (format "%d:%d:"
+ ;; (save-excursion
+ ;; (goto-char (if symbols-with-pos-enabled
+ ;; (+ byte-compile-read-position
offset)
+ ;; byte-compile-last-position)
+ ;; )
+ ;; (1+ (count-lines (point-min) (point-at-bol))))
+ ;; (save-excursion
+ ;; (goto-char (if symbols-with-pos-enabled
+ ;; (+ byte-compile-read-position
offset)
+ ;; byte-compile-last-position)
+ ;; )
+ ;; (1+ (current-column))))
+;;;; EXPERIMENTAL STOUGH, 2018-11-22
+ (let (old-l old-c new-l new-c)
+ (save-excursion
+ (goto-char byte-compile-last-position)
+ (setq old-l (1+ (count-lines (point-min)
(point-at-bol)))
+ old-c (1+ (current-column)))
+ (goto-char (+ byte-compile-read-position offset))
+ (setq new-l (1+ (count-lines (point-min)
(point-at-bol)))
+ new-c (1+ (current-column)))
+ (format "%d:%d:%d:%d:" old-l old-c new-l new-c)))
+;;;; END OF EXPERIMENTAL STOUGH
+ )
""))
(form (if (eq byte-compile-current-form :end) "end of data"
(or byte-compile-current-form "toplevel form"))))
@@ -1283,8 +1327,8 @@ function directly; use `byte-compile-warn' or
"Issue a byte compiler warning; use (format-message FORMAT ARGS...) for
message."
(setq args
(mapcar (lambda (arg)
- (if (symbol-with-pos-p arg)
- (symbol-with-pos-sym arg)
+ (if (symbolp arg)
+ (bare-symbol arg)
arg))
args))
(setq format (apply #'format-message format args))
@@ -1297,7 +1341,7 @@ function directly; use `byte-compile-warn' or
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 (push arg byte-compile--form-stack)))
+ (let ((byte-compile--form-stack (cons arg byte-compile--form-stack)))
(apply #'byte-compile-warn format args)))
(defun byte-compile-warn-obsolete (symbol)
@@ -1979,7 +2023,8 @@ The value is non-nil if there were no errors, nil if
errors."
;; within byte-compile-from-buffer lingers in that buffer.
(setq output-buffer
(save-current-buffer
- (let ((byte-compile-level (1+ byte-compile-level)))
+ (let ((symbols-with-pos-enabled t)
+ (byte-compile-level (1+ byte-compile-level)))
(byte-compile-from-buffer input-buffer))))
(if byte-compiler-error-flag
nil
@@ -2390,7 +2435,8 @@ list that represents a doc string reference.
(defvar byte-compile-force-lexical-warnings 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
@@ -2404,11 +2450,13 @@ list that represents a doc string reference.
;; byte-hunk-handlers cannot call this!
(defun byte-compile-toplevel-file-form (top-level-form)
- (byte-compile-recurse-toplevel
- top-level-form
- (lambda (form)
- (let ((byte-compile-current-form nil)) ; close over this for warnings.
- (byte-compile-file-form (byte-compile-preprocess form t))))))
+ (let ((byte-compile--form-stack
+ (cons top-level-form byte-compile--form-stack)))
+ (byte-compile-recurse-toplevel
+ top-level-form
+ (lambda (form)
+ (let ((byte-compile-current-form nil)) ; close over this for warnings.
+ (byte-compile-file-form (byte-compile-preprocess form t)))))))
;; byte-hunk-handlers can call this.
(defun byte-compile-file-form (form)
@@ -2441,7 +2489,8 @@ list that represents a doc string reference.
;; byte-compile-noruntime-functions, in case we have an autoload
;; of foo-func following an (eval-when-compile (require 'foo)).
(unless (fboundp funsym)
- (push (cons funsym (cons 'autoload (cdr (cdr form))))
+ (push (byte-compile-strip-symbol-positions
+ (cons funsym (cons 'autoload (cdr (cdr form)))))
byte-compile-function-environment))
;; If an autoload occurs _before_ the first call to a function,
;; byte-compile-callargs-warn does not add an entry to
@@ -2457,7 +2506,7 @@ list that represents a doc string reference.
(delq (assq funsym byte-compile-unresolved-functions)
byte-compile-unresolved-functions)))))
(if (stringp (nth 3 form))
- form
+ (byte-compile-strip-symbol-positions form)
;; No doc string, so we can compile this as a normal form.
(byte-compile-keep-pending form 'byte-compile-normal-call)))
@@ -2484,10 +2533,17 @@ list that represents a doc string reference.
(if (and (null (cddr form)) ;No `value' provided.
(eq (car form) 'defvar)) ;Just a declaration.
nil
+ (setq form (copy-sequence form))
(cond ((consp (nth 2 form))
- (setq form (copy-sequence form))
(setcar (cdr (cdr form))
- (byte-compile-top-level (nth 2 form) nil 'file))))
+ (byte-compile-top-level (nth 2 form) nil 'file)))
+ ((symbolp (nth 2 form))
+ (setcar (cddr form) (bare-symbol (nth 2 form))))
+ (t (setcar (cddr form)
+ (byte-compile-strip-symbol-positions (nth 2 form)))))
+ (setcar form (bare-symbol (car form)))
+ (if (symbolp (nth 1 form))
+ (setcar (cdr form) (bare-symbol (nth 1 form))))
form))
(put 'define-abbrev-table 'byte-hunk-handler
@@ -2578,7 +2634,7 @@ list that represents a doc string reference.
(put 'eval 'byte-hunk-handler 'byte-compile-file-form-eval)
(defun byte-compile-file-form-eval (form)
(if (eq (car-safe (nth 1 form)) 'quote)
- (nth 1 (nth 1 form))
+ (byte-compile-strip-symbol-positions (nth 1 (nth 1 form)))
(byte-compile-keep-pending form)))
(defun byte-compile-file-form-defmumble (name macro arglist body rest)
@@ -2594,23 +2650,24 @@ not to take responsibility for the actual compilation
of the code."
'byte-compile-macro-environment))
(this-one (assq name (symbol-value this-kind)))
(that-one (assq name (symbol-value that-kind)))
+ (bare-name (bare-symbol name))
(byte-compile-current-form name)) ; For warnings.
(byte-compile-set-symbol-position name)
- (push name byte-compile-new-defuns)
+ (push bare-name byte-compile-new-defuns)
;; When a function or macro is defined, add it to the call tree so that
;; we can tell when functions are not used.
(if byte-compile-generate-call-tree
- (or (assq name byte-compile-call-tree)
+ (or (assq bare-name byte-compile-call-tree)
(setq byte-compile-call-tree
- (cons (list name nil nil) byte-compile-call-tree))))
+ (cons (list bare-name nil nil) byte-compile-call-tree))))
(if (byte-compile-warning-enabled-p 'redefine)
(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.
@@ -2619,34 +2676,34 @@ not to take responsibility for the actual compilation
of the code."
(that-one
(if (and (byte-compile-warning-enabled-p 'redefine)
;; Don't warn when compiling the stubs in byte-run...
- (not (assq name byte-compile-initial-macro-environment)))
+ (not (assq bare-name
byte-compile-initial-macro-environment)))
(byte-compile--warn-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)
;; Hack: Don't warn when compiling the magic internal
;; byte-compiler macros in byte-run.el...
- (not (assq name byte-compile-initial-macro-environment)))
+ (not (assq bare-name
byte-compile-initial-macro-environment)))
(byte-compile--warn-x
name
"%s `%s' defined multiple times in this file"
(if macro "macro" "function")
- name)))
- ((eq (car-safe (symbol-function name))
+ bare-name)))
+ ((eq (car-safe (symbol-function bare-name))
(if macro 'lambda 'macro))
(when (byte-compile-warning-enabled-p 'redefine)
(byte-compile--warn-x
name
"%s `%s' being redefined as a %s"
(if macro "function" "macro")
- name
+ 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))))
)
@@ -2658,7 +2715,7 @@ not to take responsibility for the actual compilation of
the code."
;; FIXME: We've done that already just above, so this looks wrong!
;;(byte-compile-set-symbol-position name)
(byte-compile--warn-x
- name "probable `\"' without `\\' in doc string of %s" name))
+ name "probable `\"' without `\\' in doc string of %s" bare-name))
(if (not (listp body))
;; The precise definition requires evaluation to find out, so it
@@ -2666,7 +2723,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)
@@ -2676,10 +2733,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
@@ -2697,7 +2754,7 @@ not to take responsibility for the actual compilation of
the code."
;; b-c-output-file-form analyze the defalias.
(byte-compile-output-docform
"\n(defalias '"
- name
+ bare-name
(if macro `(" '(macro . #[" ,index "])") `(" #[" ,index "]"))
(append code nil) ; Turn byte-code-function-p into list.
(and (atom code) byte-compile-dynamic
@@ -2928,7 +2985,7 @@ for symbols generated by the byte compiler itself."
;; which may include "calls" to
;; internal-make-closure (Bug#29988).
(not lexical-binding))
- nil
+ (setq int (byte-compile-strip-symbol-positions int))
(setq int `(interactive ,newform)))))
((cdr int)
(byte-compile-warn "malformed interactive spec: %s"
@@ -2943,13 +3000,14 @@ for symbols generated by the byte compiler itself."
(and lexical-binding
(byte-compile-make-lambda-lexenv
arglistvars))
- reserved-csts)))
+ reserved-csts))
+ (bare-arglist (byte-compile-strip-symbol-positions arglist)))
;; Build the actual byte-coded function.
(cl-assert (eq 'byte-code (car-safe compiled)))
(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)
@@ -2957,7 +3015,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.
@@ -3152,7 +3210,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
@@ -3170,19 +3229,20 @@ for symbols generated by the byte compiler itself."
;;
(defun byte-compile-form (form &optional for-effect)
(let ((byte-compile--for-effect for-effect)
- (byte-compile--form-stack (push form byte-compile--form-stack)))
+ (byte-compile--form-stack (cons form byte-compile--form-stack)))
(cond
((not (consp form))
(cond ((or (not (symbolp form)) (macroexp--const-symbol-p form))
(when (symbolp form)
(byte-compile-set-symbol-position form))
- (byte-compile-constant form))
+ (byte-compile-constant
+ (if (symbolp form) (bare-symbol form) form)))
((and byte-compile--for-effect byte-compile-delete-errors)
(when (symbolp form)
(byte-compile-set-symbol-position form))
(setq byte-compile--for-effect nil))
(t
- (byte-compile-variable-ref form))))
+ (byte-compile-variable-ref (bare-symbol form)))))
((symbolp (car form))
(let* ((fn (car form))
(handler (get fn 'byte-compile))
@@ -3413,6 +3473,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))
@@ -3474,14 +3535,19 @@ for symbols generated by the byte compiler itself."
(defun byte-compile-constant (const)
(if byte-compile--for-effect
(setq byte-compile--for-effect nil)
- (inline (byte-compile-push-constant const))))
+ (inline (byte-compile-push-constant
+ (if (symbolp const) (bare-symbol const) const)))))
;; Use this for a constant that is not the value of its containing form.
;; This ignores byte-compile--for-effect.
(defun byte-compile-push-constant (const)
(when (symbolp const)
- (byte-compile-set-symbol-position const))
- (byte-compile-out 'byte-constant (byte-compile-get-constant const)))
+ (byte-compile-set-symbol-position const)
+ (setq const (bare-symbol const)))
+ (byte-compile-out
+ 'byte-constant
+ (byte-compile-get-constant
+ (byte-compile-strip-symbol-positions const))))
;; Compile those primitive ordinary functions
;; which have special byte codes just for speed.
@@ -4272,7 +4338,7 @@ Return a list of the form ((TEST . VAR) ((VALUE BODY)
...))"
(dolist (case cases)
(setq tag (byte-compile-make-tag)
- test-obj (nth 0 case)
+ test-obj (byte-compile-strip-symbol-positions (nth 0 case))
body (nth 1 case))
(byte-compile-out-tag tag)
(puthash test-obj tag jump-table)
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 010026b..bfa6d73 100644
--- a/lisp/emacs-lisp/cconv.el
+++ b/lisp/emacs-lisp/cconv.el
@@ -334,7 +334,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))
@@ -578,8 +579,8 @@ FORM is the parent form that binds this var."
(`(,_ nil nil nil nil) nil)
(`((,(and var (guard (eq ?_ (aref (symbol-name var) 0)))) . ,_)
,_ ,_ ,_ ,_)
- (byte-compile-warn
- "%s `%S' not left unused" varkind var)))
+ (byte-compile--warn-x
+ var "%s `%S' not left unused" varkind var)))
(pcase vardata
(`((,var . ,_) nil ,_ ,_ nil)
;; FIXME: This gives warnings in the wrong order, with imprecise line
@@ -591,8 +592,8 @@ FORM is the parent form that binds this var."
(eq ?_ (aref (symbol-name var) 0))
;; As a special exception, ignore "ignore".
(eq var 'ignored))
- (byte-compile-warn "Unused lexical %s `%S'"
- varkind var)))
+ (byte-compile--warn-x var "Unused lexical %s `%S'"
+ varkind var)))
;; If it's unused, there's no point converting it into a cons-cell, even if
;; it's captured and mutated.
(`(,binder ,_ t t ,_)
@@ -616,7 +617,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, ...
@@ -700,7 +702,8 @@ and updates the data stored in ENV."
(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)))
@@ -728,8 +731,8 @@ and updates the data stored in ENV."
(`(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 c7f0c48..0da434d 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -437,7 +437,8 @@ The set of acceptable TYPEs (also called \"specializers\")
is defined
cl-generic-method-args ; arguments
lambda-doc ; documentation string
def-body))) ; part to be debugged
- (let ((qualifiers nil))
+ (let ((qualifiers nil)
+ (org-name name))
(while (not (listp args))
(push args qualifiers)
(setq args (pop body)))
@@ -451,6 +452,7 @@ The set of acceptable TYPEs (also called \"specializers\")
is defined
(byte-compile-warning-enabled-p 'obsolete))
(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 29ddd49..47afc72 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -53,6 +53,36 @@
`(prog1 (car (cdr ,place))
(setq ,place (cdr (cdr ,place)))))
+(defun cl-macs--strip-s-p-1 (arg)
+ "Strip all positions from symbols with position in ARG, destructively
modifying ARG
+Return the modified ARG."
+ (cond
+ ((symbolp arg)
+ (bare-symbol arg))
+ ((consp arg)
+ (let ((a arg))
+ (while (consp (cdr a))
+ (setcar a (cl-macs--strip-s-p-1 (car a)))
+ (setq a (cdr a)))
+ (setcar a (cl-macs--strip-s-p-1 (car a)))
+ ;; (if (cdr a)
+ (unless (bare-symbol-p (cdr a)) ; includes (unpositioned) nil.
+ (setcdr a (cl-macs--strip-s-p-1 (cdr a)))))
+ arg)
+ ((vectorp arg)
+ (let ((i 0)
+ (len (length arg)))
+ (while (< i len)
+ (aset arg i (cl-macs--strip-s-p-1 (aref arg i)))
+ (setq i (1+ i))))
+ arg)
+ (t arg)))
+
+(defun cl-macs--strip-symbol-positions (arg)
+ "Strip all positions from symbols (recursively) in ARG. Don't modify ARG."
+ (let ((arg1 (copy-tree arg t)))
+ (cl-macs--strip-s-p-1 arg1)))
+
(defvar cl--optimize-safety)
(defvar cl--optimize-speed)
@@ -2280,10 +2310,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)))))
@@ -2886,7 +2918,8 @@ non-nil value, that slot cannot be set via `setf'.
;; and pred-check, so changing it is not straightforward.
(push `(cl-defsubst ,accessor (cl-x)
,(format "Access slot \"%s\" of `%s' struct CL-X."
- slot struct)
+ (cl-macs--strip-symbol-positions slot)
+ (cl-macs--strip-symbol-positions struct))
(declare (side-effect-free t))
,@(and pred-check
(list `(or ,pred-check
@@ -2899,6 +2932,7 @@ non-nil value, that slot cannot be set via `setf'.
(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)
@@ -2908,6 +2942,7 @@ non-nil value, that slot cannot be set via `setf'.
(let ((kw (car defaults)))
(push
(macroexp--warn-and-return
+ kw
(format " I'll take `%s' to be an option rather than a
default value."
kw)
'nil)
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el
index e5c4f19..1e9555c 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -721,6 +721,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 'compile-only))
(_ exp)))))
(cl-check-type slot symbol)
diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el
index 98cdd4f..84804a0 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -270,6 +270,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 6bfc32c..704c764 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -540,7 +540,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))))))
@@ -552,6 +554,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 93678ba..e69f93c 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -121,8 +121,8 @@ and also to avoid outputting the warning during normal
execution."
(defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key))
-(defun macroexp--warn-and-return (msg form &optional compile-only)
- (let ((when-compiled (lambda () (byte-compile-warn "%s" msg))))
+(defun macroexp--warn-and-return (arg msg form &optional compile-only)
+ (let ((when-compiled (lambda () (byte-compile--warn-x arg "%s" msg))))
(cond
((null msg) form)
((macroexp--compiling-p)
@@ -190,6 +190,7 @@ and also to avoid outputting the warning during normal
execution."
(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))
@@ -252,12 +253,14 @@ Assumes the caller has bound
`macroexpand-all-environment'."
(`(,(and fun (or `funcall `apply `mapcar `mapatoms `mapconcat `mapc))
',(and f `(lambda . ,_)) . ,args)
(macroexp--warn-and-return
+ (nth 1 f)
(format "%s quoted with ' rather than with #'"
(list 'lambda (nth 1 f) '...))
(macroexp--expand-all `(,fun ,f . ,args))))
;; Second arg is a function:
(`(,(and fun (or `sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args)
(macroexp--warn-and-return
+ (nth 1 f)
(format "%s quoted with ' rather than with #'"
(list 'lambda (nth 1 f) '...))
(macroexp--expand-all `(,fun ,arg1 ,f . ,args))))
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 2746738..826bafc 100644
--- a/lisp/emacs-lisp/pcase.el
+++ b/lisp/emacs-lisp/pcase.el
@@ -819,6 +819,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/src/alloc.c b/src/alloc.c
index 1b4212f..f37d7d4 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -6001,9 +6001,12 @@ See Info node `(elisp)Garbage Collection'. */
attributes: noinline)
(void)
{
+ ptrdiff_t count = SPECPDL_INDEX ();
void *end;
+ specbind (Qsymbols_with_pos_enabled, Qnil);
SET_STACK_TOP_ADDRESS (&end);
- return garbage_collect_1 (end);
+ /* return garbage_collect_1 (end); */
+ return unbind_to (count, garbage_collect_1 (end));
}
/* Mark Lisp objects in glyph matrix MATRIX. Currently the
diff --git a/src/data.c b/src/data.c
index d311cba..6c65625 100644
--- a/src/data.c
+++ b/src/data.c
@@ -772,12 +772,14 @@ DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
return name;
}
-DEFUN ("symbol-with-pos-sym", Fsymbol_with_pos_sym, Ssymbol_with_pos_sym, 1,
1, 0,
- doc: /* Extract the symbol from a symbol with position. */)
- (register Lisp_Object ls)
+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 (ls);
+ return SYMBOL_WITH_POS_SYM (sym);
}
DEFUN ("symbol-with-pos-pos", Fsymbol_with_pos_pos, Ssymbol_with_pos_pos, 1,
1, 0,
@@ -4073,7 +4075,7 @@ syms_of_data (void)
defsubr (&Sindirect_function);
defsubr (&Ssymbol_plist);
defsubr (&Ssymbol_name);
- defsubr (&Ssymbol_with_pos_sym);
+ defsubr (&Sbare_symbol);
defsubr (&Ssymbol_with_pos_pos);
defsubr (&Sposition_symbol);
defsubr (&Smakunbound);
@@ -4151,6 +4153,7 @@ 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_LISP ("symbols-with-pos-enabled", Vsymbols_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. */);
diff --git a/src/fns.c b/src/fns.c
index 138cd08..b5bf6ae 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -4141,6 +4141,8 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key,
EMACS_UINT *hash)
EMACS_UINT hash_code;
ptrdiff_t start_of_bucket, i;
+ if (SYMBOL_WITH_POS_P (key))
+ key = SYMBOL_WITH_POS_SYM (key);
hash_code = h->test.hashfn (&h->test, key);
eassert ((hash_code & ~INTMASK) == 0);
if (hash)
diff --git a/src/lisp.h b/src/lisp.h
index d2391aa..4dfd065 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -398,13 +398,13 @@ typedef EMACS_INT Lisp_Word;
|| (Vsymbols_with_pos_enabled \
&& (SYMBOL_WITH_POS_P ((x)) \
? BARE_SYMBOL_P ((y)) \
- ? (lisp_h_XSYMBOL_WITH_POS((x)))->sym == (y) \
+ ? (XSYMBOL_WITH_POS((x)))->sym == (y) \
: SYMBOL_WITH_POS_P((y)) \
- && ((lisp_h_XSYMBOL_WITH_POS((x)))->sym \
- == (lisp_h_XSYMBOL_WITH_POS((y)))->sym) \
+ && ((XSYMBOL_WITH_POS((x)))->sym \
+ == (XSYMBOL_WITH_POS((y)))->sym) \
: (SYMBOL_WITH_POS_P ((y)) \
&& BARE_SYMBOL_P ((x)) \
- && ((x) == ((lisp_h_XSYMBOL_WITH_POS ((y)))->sym))))))
+ && ((x) == ((XSYMBOL_WITH_POS ((y)))->sym))))))
#define lisp_h_FIXNUMP(x) \
(! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \
@@ -420,11 +420,11 @@ 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_SYMBOL_WITH_POS_P(x) lisp_h_PSEUDOVECTORP (XIL((x)),
PVEC_SYMBOL_WITH_POS)
+#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)
/* verify (NIL_IS_ZERO) */
-#define lisp_h_SYMBOLP(x) ((lisp_h_BARE_SYMBOL_P ((x)) || \
- (Vsymbols_with_pos_enabled &&
(lisp_h_SYMBOL_WITH_POS_P ((x))))))
+#define lisp_h_SYMBOLP(x) ((BARE_SYMBOL_P ((x)) || \
+ (Vsymbols_with_pos_enabled && (SYMBOL_WITH_POS_P
((x))))))
#define lisp_h_TAGGEDP(a, tag) \
(! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \
- (unsigned) (tag)) \
@@ -445,7 +445,7 @@ typedef EMACS_INT Lisp_Word;
# define lisp_h_XFIXNUM(a) (XLI (a) >> INTTYPEBITS)
# ifdef __CHKP__
# define lisp_h_XBARE_SYMBOL(a) \
- (eassert (BARE_SYMBOL_P ((a))), \
+ (eassert (BARE_SYMBOL_P ((a))), \
(struct Lisp_Symbol *) ((char *) XUNTAG ((a), Lisp_Symbol, \
struct Lisp_Symbol) \
+ (intptr_t) lispsym))
@@ -464,10 +464,10 @@ typedef EMACS_INT Lisp_Word;
# define lisp_h_XSYMBOL(a) \
(eassert (SYMBOLP ((a))), \
(!Vsymbols_with_pos_enabled \
- ? (lisp_h_XBARE_SYMBOL ((a))) \
- : (lisp_h_BARE_SYMBOL_P ((a))) \
- ? (lisp_h_XBARE_SYMBOL ((a))) \
- : lisp_h_XBARE_SYMBOL (lisp_h_XSYMBOL_WITH_POS ((a))->sym)))
+ ? (XBARE_SYMBOL ((a))) \
+ : (BARE_SYMBOL_P ((a))) \
+ ? (XBARE_SYMBOL ((a))) \
+ : XBARE_SYMBOL (XSYMBOL_WITH_POS ((a))->sym)))
# define lisp_h_XTYPE(a) ((enum Lisp_Type) (XLI (a) & ~VALMASK))
#endif
@@ -488,12 +488,13 @@ typedef EMACS_INT Lisp_Word;
# define XIL(i) lisp_h_XIL (i)
# define XLP(o) lisp_h_XLP (o)
# define XPL(p) lisp_h_XPL (p)
+# 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 BASE_EQ(x, y) lisp_h_BASE_EQ (x, y)
-/* # define EQ(x, y) lisp_h_EQ (x, y) */
+/* # define EQ(x, y) lisp_h_EQ (x, y) */ /* X, Y are accessed more than once.
*/
# define FLOATP(x) lisp_h_FLOATP (x)
# define FIXNUMP(x) lisp_h_FIXNUMP (x)
# define NILP(x) lisp_h_NILP (x)
@@ -501,8 +502,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 BARE_SYMBOL_P(x) lisp_h_BARE_SYMBOL_P (x)
-/* # 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)
@@ -514,10 +514,10 @@ typedef EMACS_INT Lisp_Word;
# endif
# if USE_LSB_TAG
# define make_fixnum(n) lisp_h_make_fixnum (n)
+# define XBARE_SYMBOL(a) lisp_h_XBARE_SYMBOL (a)
# define XFIXNAT(a) lisp_h_XFIXNAT (a)
# define XFIXNUM(a) lisp_h_XFIXNUM (a)
-# define XBARE_SYMBOL(a) lisp_h_XBARE_SYMBOL (a)
-/* # define XSYMBOL(a) lisp_h_XSYMBOL (a) */
+/* # define XSYMBOL(a) lisp_h_XSYMBOL (a) */ /* A is accessed more than once.
*/
# define XTYPE(a) lisp_h_XTYPE (a)
# endif
#endif
@@ -1029,6 +1029,18 @@ enum More_Lisp_Bits
#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);
@@ -1040,13 +1052,20 @@ INLINE bool
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
-(XSYMBOL) (Lisp_Object a)
+(XBARE_SYMBOL) (Lisp_Object a)
{
#if USE_LSB_TAG
- return lisp_h_XSYMBOL (a);
+ return lisp_h_XBARE_SYMBOL (a);
#else
- eassert (SYMBOLP (a));
+ eassert (BARE_SYMBOL_P (a));
intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol);
void *p = (char *) lispsym + i;
# ifdef __CHKP__
@@ -1058,6 +1077,12 @@ INLINE struct Lisp_Symbol *
ATTRIBUTE_NO_SANITIZE_UNDEFINED
#endif
}
+INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED
+(XSYMBOL) (Lisp_Object a)
+{
+ return lisp_h_XSYMBOL (a);
+}
+
INLINE Lisp_Object
make_lisp_symbol (struct Lisp_Symbol *sym)
{
@@ -1194,7 +1219,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)
{
@@ -1640,12 +1672,6 @@ PSEUDOVECTOR_TYPEP (union vectorlike_header *a, enum
pvec_type code)
== (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS)));
}
-INLINE bool
-PSEUDOVECTORP (Lisp_Object a, int code)
-{
- return lisp_h_PSEUDOVECTORP (a, code);
-}
-
/* A boolvector is a kind of vectorlike, with contents like a string. */
struct Lisp_Bool_Vector
@@ -2525,13 +2551,6 @@ XOVERLAY (Lisp_Object a)
return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Overlay);
}
-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 Lisp_Object
SYMBOL_WITH_POS_SYM (Lisp_Object a)
{
diff --git a/src/lread.c b/src/lread.c
index 38a7286..9609770 100644
--- a/src/lread.c
+++ b/src/lread.c
@@ -2813,7 +2813,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
/* 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, locate_syms);
+ Lisp_Object tmp = read_list (0, readcharfun, false);
Lisp_Object head = CAR_SAFE (tmp);
Lisp_Object data = Qnil;
Lisp_Object val = Qnil;
@@ -2899,7 +2899,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
if (c == '[')
{
Lisp_Object tmp;
- tmp = read_vector (readcharfun, 0, locate_syms);
+ tmp = read_vector (readcharfun, 0, false);
if (ASIZE (tmp) < CHAR_TABLE_STANDARD_SLOTS)
error ("Invalid size char-table");
XSETPVECTYPE (XVECTOR (tmp), PVEC_CHAR_TABLE);
@@ -2912,7 +2912,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
{
/* 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,
locate_syms);
+ Lisp_Object tbl, tmp = read_list (1, readcharfun, false);
ptrdiff_t size = XFIXNUM (Flength (tmp));
int i, depth, min_char;
struct Lisp_Cons *cell;
@@ -2950,7 +2950,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
if (c == '&')
{
Lisp_Object length;
- length = read1 (readcharfun, pch, first_in_list, locate_syms);
+ length = read1 (readcharfun, pch, first_in_list, false);
c = READCHAR;
if (c == '"')
{
@@ -2959,7 +2959,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
unsigned char *data;
UNREAD (c);
- tmp = read1 (readcharfun, pch, first_in_list, locate_syms);
+ 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
@@ -3000,7 +3000,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
int ch;
/* Read the string itself. */
- tmp = read1 (readcharfun, &ch, 0, locate_syms);
+ tmp = read1 (readcharfun, &ch, 0, false);
if (ch != 0 || !STRINGP (tmp))
invalid_syntax ("#");
/* Read the intervals and their properties. */
@@ -3008,14 +3008,14 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
{
Lisp_Object beg, end, plist;
- beg = read1 (readcharfun, &ch, 0, locate_syms);
+ beg = read1 (readcharfun, &ch, 0, false);
end = plist = Qnil;
if (ch == ')')
break;
if (ch == 0)
- end = read1 (readcharfun, &ch, 0, locate_syms);
+ end = read1 (readcharfun, &ch, 0, false);
if (ch == 0)
- plist = read1 (readcharfun, &ch, 0, locate_syms);
+ plist = read1 (readcharfun, &ch, 0, false);
if (ch)
invalid_syntax ("Invalid string property list");
Fset_text_properties (beg, end, plist, tmp);
diff --git a/src/print.c b/src/print.c
index c8432a3..fc5d931 100644
--- a/src/print.c
+++ b/src/print.c
@@ -1397,19 +1397,24 @@ print_vectorlike (Lisp_Object obj, Lisp_Object
printcharfun, bool escapeflag,
case PVEC_SYMBOL_WITH_POS:
{
struct Lisp_Symbol_With_Pos *sp = XSYMBOL_WITH_POS (obj);
- print_c_string ("#<symbol ", printcharfun);
- if (BARE_SYMBOL_P (sp->sym))
+ if (!NILP (Vprint_symbols_bare))
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);
+ 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);
}
- else
- print_c_string (" NOT A POSITION!!", printcharfun);
- printchar ('>', printcharfun);
}
break;
@@ -2348,6 +2353,12 @@ priorities. Values other than nil or t are also treated
as
`default'. */);
Vprint_charset_text_property = Qdefault;
+ DEFVAR_LISP ("print-symbols-bare", Vprint_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. */);
+ Vprint_symbols_bare = Qnil;
+
/* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */
staticpro (&Vprin1_to_string_buffer);
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] scratch/accurate-warning-pos 75b18e0: Bring the scratch/accurate-warning-pos branch to full functionality.,
Alan Mackenzie <=