procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Several amendments to scratch/correct-warning-pos.

Browse source 
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.
This commit is contained in:
Alan Mackenzie 2021-12-01 20:03:44 +00:00
parent 368570b3fd
commit 8f1106ddf2
15 changed files with 66 additions and 47 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -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)

4
lisp/emacs-lisp/byte-run.el
View file

@ -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)))))

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

@ -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

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

@ -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)

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

@ -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

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

@ -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)

1
lisp/emacs-lisp/easy-mmode.el
View file

@ -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)

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

@ -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)))))

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

@ -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,

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

@ -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))))

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

@ -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) ...))))

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

@ -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)

16
src/data.c
View file

@ -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);

10
src/lisp.h
View file

@ -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)) \

13
src/lread.c
View file

@ -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
{