[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
scratch/correct-warning-pos 8f1106d: Several amendments to scratch/corre
|
From: |
Alan Mackenzie |
|
Subject: |
scratch/correct-warning-pos 8f1106d: Several amendments to scratch/correct-warning-pos. |
|
Date: |
Wed, 1 Dec 2021 15:06:33 -0500 (EST) |
branch: scratch/correct-warning-pos
commit 8f1106ddf2a3861e9c1ebb9d8fa3d4087899de81
Author: Alan Mackenzie <acm@muc.de>
Commit: Alan Mackenzie <acm@muc.de>
Several amendments to scratch/correct-warning-pos.
The position return by read-positioning-symbols is now the position in the
buffer, rather than the offset from the start of a form, enabling warning
positions in other parts of the buffer to be output.
* src/lisp.h (lisp_h_EQ): Add XLI casts so that it compiles cleanly.
* src/data.c (Fremove_pos_from_symbol): New DEFUN.
* src/lread.c (readchar_count): renamed to readchar_offset.
(read_internal_start) Initialize readchar_offset to the buffer's point when
STREAM is a buffer.
* lisp/emacs-lisp/bytecomp.el (byte-compile-warning-prefix): Amend to use
OFFSET as a buffer position, not an offset from the start of a form.
(byte-compile-warn): Remove symbol positions from any shape of ARGS, not
just
a symbol with position.
* lisp/emacs-lisp/cconv.c (cconv-convert): In the :unused case, position the
new IGNORE symbol with the VAR it has replaced.
* lisp/emacs-lisp/macroexp.el (macroexp--warn-wrap,
macroexp-warn-and-return):
Add an extra position parameter to each.
* lisp/emacs-lisp/bindat.el (bindat-type), lisp/emacs-lisp/byte-run.el
(defmacro, defun), lisp/emacs-lisp/cconv.el (cconv--convert-func-body)
(cconv-convert), lisp/emacs-lisp/cl-generic.el (cl-defmethod),
lisp/emacs-lisp/cl-macs.el (cl-symbol-macrolet, cl-defstruct),
lisp/emacs-lisp/easy-mmode.el (define-minor-mode),
lisp/emacs-lisp/eieio-core.el (eieio-oref, eieio-oref-default)
(eieio-oset-default), lisp/emacs-lisp/eieio.el (defclass),
lisp/emacs-lisp/gv.el (gv-ref), lisp/emacs-lisp/macroexp.el
(macroexp-macroexpand, macroexp--unfold-lambda, macroexp--expand-all),
lisp/emacs-lisp/pcase.el (pcase-compile-patterns, pcase--u1): Add an extra
position argument to each call of macroexp-warn-and-return.
---
lisp/emacs-lisp/bindat.el | 1 +
lisp/emacs-lisp/byte-run.el | 4 +++-
lisp/emacs-lisp/bytecomp.el | 9 ++-------
lisp/emacs-lisp/cconv.el | 19 +++++++++++--------
lisp/emacs-lisp/cl-generic.el | 2 +-
lisp/emacs-lisp/cl-macs.el | 6 +++---
lisp/emacs-lisp/easy-mmode.el | 1 +
lisp/emacs-lisp/eieio-core.el | 6 +++++-
lisp/emacs-lisp/eieio.el | 5 +++--
lisp/emacs-lisp/gv.el | 2 +-
lisp/emacs-lisp/macroexp.el | 16 ++++++++--------
lisp/emacs-lisp/pcase.el | 3 ++-
src/data.c | 16 ++++++++++++++--
src/lisp.h | 10 +++++-----
src/lread.c | 13 ++++++-------
15 files changed, 66 insertions(+), 47 deletions(-)
diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el
index 76c2e80..17a55c7 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-run.el b/lisp/emacs-lisp/byte-run.el
index d82d945..813ff53 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -253,7 +253,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)
@@ -327,6 +328,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 869b6c0..2f23fe7 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -1326,7 +1326,7 @@ Return nil if such is not found."
(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))
+ (goto-char 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)))
@@ -1435,12 +1435,7 @@ function directly; use `byte-compile-warn' or
(defun byte-compile-warn (format &rest args)
"Issue a byte compiler warning; use (format-message FORMAT ARGS...) for
message."
- (setq args
- (mapcar (lambda (arg)
- (if (symbolp arg)
- (bare-symbol arg)
- arg))
- args))
+ (setq args (mapcar #'byte-compile-strip-symbol-positions args))
(setq format (apply #'format-message format args))
(if byte-compile-error-on-warn
(error "%s" format) ; byte-compile-file catches and logs it
diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el
index 9c9ebe1..e12f0a1 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)
@@ -414,11 +414,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.
(_
@@ -517,7 +520,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)
diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el
index b94737e..43214aa 100644
--- a/lisp/emacs-lisp/cl-generic.el
+++ b/lisp/emacs-lisp/cl-generic.el
@@ -512,7 +512,7 @@ The set of acceptable TYPEs (also called \"specializers\")
is defined
(byte-compile-warning-enabled-p 'obsolete name))
(let* ((obsolete (get name 'byte-obsolete-info)))
(macroexp-warn-and-return
- ;; org-name
+ 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 dbe0eb1..3659a0c 100644
--- a/lisp/emacs-lisp/cl-macs.el
+++ b/lisp/emacs-lisp/cl-macs.el
@@ -2449,7 +2449,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf
EXPANSION ...).
(if malformed-bindings
(let ((rev-malformed-bindings (nreverse malformed-bindings)))
(macroexp-warn-and-return
- ;; rev-malformed-bindings
+ rev-malformed-bindings
(format-message "Malformed `cl-symbol-macrolet' binding(s):
%S"
rev-malformed-bindings)
expansion))
@@ -3136,7 +3136,7 @@ To see the documentation for a defined struct type, use
(when (cl-oddp (length desc))
(push
(macroexp-warn-and-return
- ;; (car (last desc))
+ (car (last desc))
(format "Missing value for option `%S' of slot `%s' in
struct %s!"
(car (last desc)) slot name)
'nil)
@@ -3146,7 +3146,7 @@ To see the documentation for a defined struct type, use
(let ((kw (car defaults)))
(push
(macroexp-warn-and-return
- ;; kw
+ kw
(format " I'll take `%s' to be an option rather than a
default value."
kw)
'nil)
diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el
index db86e0e..59038f6 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 4e9357c..b17ecd3 100644
--- a/lisp/emacs-lisp/eieio-core.el
+++ b/lisp/emacs-lisp/eieio-core.el
@@ -744,7 +744,7 @@ Argument FN is the function calling this verifier."
((and (or `',name (and name (pred keywordp)))
(guard (not (memq name eieio--known-slot-names))))
(macroexp-warn-and-return
- ;; name
+ name
(format-message "Unknown slot `%S'" name)
exp nil 'compile-only))
(_ exp))))
@@ -781,11 +781,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)))))
@@ -843,11 +845,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 76f7b66..0d0dff6 100644
--- a/lisp/emacs-lisp/eieio.el
+++ b/lisp/emacs-lisp/eieio.el
@@ -242,7 +242,8 @@ This method is obsolete."
`(progn
,@(mapcar (lambda (w)
- (macroexp-warn-and-return w `(progn ',w) nil 'compile-only))
+ (macroexp-warn-and-return w ; W is probably a poor choice
for a position.
+ w `(progn ',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,7 +293,7 @@ This method is obsolete."
(if (not (stringp (car slots)))
whole
(macroexp-warn-and-return
- ;; (car slots)
+ (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 ed33524..eb65e5f 100644
--- a/lisp/emacs-lisp/gv.el
+++ b/lisp/emacs-lisp/gv.el
@@ -595,7 +595,7 @@ binding mode."
(eq (car-safe code) 'cons))
code
(macroexp-warn-and-return
- ;; org-place
+ 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 6d114a8..60fac98 100644
--- a/lisp/emacs-lisp/macroexp.el
+++ b/lisp/emacs-lisp/macroexp.el
@@ -135,18 +135,17 @@ 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 (byte-compile-warning-enabled-p category)
- (byte-compile-warn-x form "%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 (;; _arg
- msg form &optional category compile-only)
+(defun macroexp-warn-and-return (arg msg form &optional category compile-only)
"Return code equivalent to FORM labeled with warning MSG.
CATEGORY is the category of the warning, like the categories that
can appear in `byte-compile-warnings'.
@@ -161,7 +160,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"
@@ -217,7 +216,7 @@ is executed without being compiled first."
(let* ((fun (car form))
(obsolete (get fun 'byte-obsolete-info)))
(macroexp-warn-and-return
- ;; fun
+ fun
(macroexp--obsolete-warning
fun obsolete
(if (symbolp (symbol-function fun))
@@ -273,6 +272,7 @@ is executed without being compiled first."
(setq arglist (cdr arglist)))
(if values
(macroexp-warn-and-return
+ name
(format (if (eq values 'too-few)
"attempt to open-code `%s' with too few arguments"
"attempt to open-code `%s' with too many arguments")
@@ -332,7 +332,7 @@ Assumes the caller has bound `macroexpand-all-environment'."
(if (null body)
(macroexp-unprogn
(macroexp-warn-and-return
- ;; fun
+ fun
(format "Empty %s body" fun)
nil nil 'compile-only))
(macroexp--all-forms body))
@@ -370,7 +370,7 @@ Assumes the caller has bound `macroexpand-all-environment'."
(eq 'lambda (car-safe (cadr arg))))
(setcar (nthcdr funarg form)
(macroexp-warn-and-return
- ;; (nth 1 f)
+ (cadr arg)
(format "%S quoted with ' rather than with #'"
(let ((f (cadr arg)))
(if (symbolp f) f `(lambda ,(nth 1 f) ...))))
diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el
index 430ae97..81280d4 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,7 +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
+ upat
"Pattern t is deprecated. Use `_' instead"
code))))
((eq upat 'pcase--dontcare) :pcase--dontcare)
diff --git a/src/data.c b/src/data.c
index b3b157a..1f2af6f 100644
--- a/src/data.c
+++ b/src/data.c
@@ -776,7 +776,7 @@ DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0,
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)
+ (register Lisp_Object sym)
{
if (BARE_SYMBOL_P (sym))
return sym;
@@ -786,12 +786,23 @@ DEFUN ("bare-symbol", Fbare_symbol, Sbare_symbol, 1, 1, 0,
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)
+ (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.
@@ -4193,6 +4204,7 @@ syms_of_data (void)
defsubr (&Ssymbol_name);
defsubr (&Sbare_symbol);
defsubr (&Ssymbol_with_pos_pos);
+ defsubr (&Sremove_pos_from_symbol);
defsubr (&Sposition_symbol);
defsubr (&Smakunbound);
defsubr (&Sfmakunbound);
diff --git a/src/lisp.h b/src/lisp.h
index 08013e9..00d9843 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -366,7 +366,7 @@ typedef EMACS_INT Lisp_Word;
#define lisp_h_PSEUDOVECTORP(a,code) \
(lisp_h_VECTORLIKEP((a)) && \
- ((XUNTAG ((a), Lisp_Vectorlike, union vectorlike_header)->size \
+ ((XUNTAG ((a), Lisp_Vectorlike, union vectorlike_header)->size \
& (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) \
== (PSEUDOVECTOR_FLAG | ((code) << PSEUDOVECTOR_AREA_BITS))))
@@ -382,13 +382,13 @@ typedef EMACS_INT Lisp_Word;
|| (symbols_with_pos_enabled \
&& (SYMBOL_WITH_POS_P ((x)) \
? BARE_SYMBOL_P ((y)) \
- ? (XSYMBOL_WITH_POS((x)))->sym == (y) \
+ ? XLI (XSYMBOL_WITH_POS((x))->sym) == XLI (y) \
: SYMBOL_WITH_POS_P((y)) \
- && ((XSYMBOL_WITH_POS((x)))->sym \
- == (XSYMBOL_WITH_POS((y)))->sym) \
+ && (XLI (XSYMBOL_WITH_POS((x))->sym) \
+ == XLI (XSYMBOL_WITH_POS((y))->sym)) \
: (SYMBOL_WITH_POS_P ((y)) \
&& BARE_SYMBOL_P ((x)) \
- && ((x) == ((XSYMBOL_WITH_POS ((y)))->sym))))))
+ && (XLI (x) == XLI ((XSYMBOL_WITH_POS ((y)))->sym))))))
#define lisp_h_FIXNUMP(x) \
(! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \
diff --git a/src/lread.c b/src/lread.c
index 7775911..1cc5acc 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. */
@@ -2518,7 +2517,7 @@ read_internal_start (Lisp_Object stream, Lisp_Object
start, Lisp_Object end,
{
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)
@@ -3773,7 +3772,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool
first_in_list, bool locate_syms)
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
{
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- scratch/correct-warning-pos 8f1106d: Several amendments to scratch/correct-warning-pos.,
Alan Mackenzie <=