diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 76c2e80fda8..17a55c7dbaa 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 d82d9454e84..813ff53ea73 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 869b6c01b8a..2f23fe743ec 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 9c9ebe15d5d..e12f0a1753b 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 b94737e0fee..43214aab30c 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 dbe0eb1b0e2..3659a0c95a2 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 db86e0e0292..59038f6e9b2 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 4e9357c2ada..b17ecd34d4d 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 76f7b661a62..0d0dff6d68e 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 ed33524f2dc..eb65e5f1046 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 6d114a8a547..60fac981308 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 430ae97078c..81280d4e041 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 b3b157a7f39..1f2af6f4743 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 08013e94d16..00d9843d6a3 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 7775911c1d3..1cc5acc6d3a 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 {