From 368570b3fd09d03ac5b9276d1ca85ae813c3f385 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Mon, 29 Nov 2021 11:19:31 +0000 Subject: [PATCH] First commit of scratch/correct-warning-pos. This branch is intended to generate correct position information in warning and error messages from the byte compiler, and is intended thereby to fix bugs It introduces a new mechanism, the symbol with position. This is taken over from the previous git branch scratch/accurate-warning-pos which was abandoned for being too slow. The main difference in the current branch is that the symbol `nil' is never given a position, thus speeding up NILP markedly. * lisp/emacs-lisp/byte-opt.el (byte-compile-inline-expand) (byte-optimize-form-code-walker, byte-optimize-let-form, byte-optimize-while) (byte-optimize-apply): Use byte-compile-warn-x in place of byte-compile-warn. * lisp/emacs-lisp/bytecomp.el (byte-compile--form-stack): New variable. (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. (byte-compile--first-symbol, byte-compile--warning-source-offset): New functions. (byte-compile-warning-prefix): Modify to output two sets of position information, the old (incorrect) set and the new set. (byte-compile-warn): Strip positions from symbols before outputting. (byte-compile-warn-x): New function which outputs a correct position supplied in an argument. (byte-compile-warn-obsolete, byte-compile-emit-callargs-warn) (byte-compile-format-warn, byte-compile-nogroup-warn) (byte-compile-arglist-warn, byte-compile-docstring-length-warn) (byte-compile-warn-about-unresolved-functions, byte-compile-file) (byte-compile--check-prefixed-var, byte-compile--declare-var) (byte-compile-file-form-defvar-function, byte-compile-file-form-defmumble) (byte-compile-check-lambda-list, byte-compile--warn-lexical-dynamic) (byte-compile-lambda, byte-compile-form, byte-compile-normal-call) (byte-compile-check-variable, byte-compile-free-vars-warn) (byte-compile-subr-wrong-args, byte-compile-fset, byte-compile-set-default) (byte-compile-condition-case, byte-compile-save-excursion) (byte-compile-defvar, byte-compile-autoload) (byte-compile-make-variable-buffer-local, byte-compile-define-symbol-prop) (byte-compile-define-keymap): Replace byte-compile-warn with byte-compile-warn-x. (byte-compile-file, compile-defun): Bind symbols-with-pos-enabled to non-nil. (compile-defun, byte-compile-from-buffer): Use `read-positioning-symbols' rather than plain `read'. (byte-compile-toplevel-file-form, byte-compile-form): Dynamically bind byte-compile--form-stack. (byte-compile-file-form-autoload, byte-compile-file-form-defvar) (byte-compile-file-form-make-obsolete, byte-compile-lambda) (byte-compile-push-constant, byte-compile-cond-jump-table) (byte-compile-define-keymap, byte-compile-annotate-call-tree): Strip positions from symbols where they are unwanted. (byte-compile-file-form-defvar): Strip positions from symbols using `bare-symbol'. (byte-compile-file-form-defmumble): New variable bare-name, a version of name without its position. (byte-compile-lambda): Similarly, new variable bare-arglist. (byte-compile-free-vars-warn): New argument arg supplying position information to byte-compile-warn-x. (byte-compile-push-constant): Manipulation of symbol positions. (display-call-tree): Strip positions from symbols. * lisp/emacs-lisp/cconv.el (cconv-convert, cconv--analyze-use) (cconv--analyze-function, cconv-analyze-form): Replace use of byte-compile-warn with byte-compile-warn-x. * lisp/emacs-lisp/cl-generic.el (cl-defmethod): New variable org-name which will supply position information to a new macroexp-warn-and-return. * lisp/emacs-lisp/cl-macs.el (cl-macs--strip-s-p-1) (cl-macs--strip-symbol-positions): New functions to strip positions from symbols in an expression. These duplicaate similarly named functions in bytecomp.el. * lisp/emacs-lisp/macroexpand.el (macroexp--warn-wrap): Calls byte-compile-warn-x in place of byte-compile-warn. (macroexp-warn-and-return): Commented out new position parameter _arg. * src/.gdbinit: Add in code to handle symbols with position. * src/alloc.c (XPNTR, set_symbol_name, valid_lisp_object_p, purecopy) (mark_char_table, mark_object, survives_gc_p, symbol_uses_obj): Use BARE_SYMBOL_P and XBARE_SYMBOL in place of the former SYMBOLP and XSYMBOL. (build_symbol_with_pos): New function. (Fgarbage_collect): Bind Qsymbols_with_pos_enabled to nil around the call to garbage_collect. * src/data.c (Ftype_of): Add case for PVEC_SYMBOL_WITH_POS. (Fbare_symbol_p, Fsymbol_with_pos_p, Fbare_symbol, Fsymbol_with_pos_pos) (Fposition_symbol): New functions. (symbols_with_pos_enabled): New boolean variable. * src/fns.c (internal_equal, hash_lookup): Handle symbols with position. * src/keyboard.c (recursive_edit_1): Bind Qsymbols_with_pos_enabled and Qprint_symbols_bare to nil. * src/lisp.h (lisp_h_PSEUDOVECTORP): New macro. (lisp_h_BASE_EQ): New name for the former lisp_h_EQ. (lisp_h_EQ): Extended to handle symbols with position. (lisp_h_NILP): Now uses BASE_EQ rather than EQ. (lisp_h_SYMBOL_WITH_POS_P, lisp_h_BARE_SYMBOL_P): New macros. (lisp_h_SYMBOLP): Redefined to handle symbols with position. (BARE_SYMBOL_P, BASE_EQ): New macros. (SYMBOLP (macro)): Removed. (SYMBOLP (function), XSYMBOL, make_lisp_symbol, builtin_lisp_symbol) (c_symbol_p): Moved to later in file. (struct Lisp_Symbol_With_Pos): New data type. (pvec_type): PVEC_SYMBOL_WITH_POS: New type code. (PSEUDOVECTORP): Redefined to use the lisp_h_PSEUDOVECTORP. (BARE_SYMBOL_P, SYMBOL_WITH_POS_P, SYMBOLP, XSYMBOL_WITH_POS, XBARE_SYMBOL) (XSYMBOL, make_lisp_symbol, builtin_lisp_symbol, c_symbol_p, CHECK_SYMBOL) (BASE_EQ): New functions, or functions moved from earlier in the file. (SYMBOL_WITH_POS_SYM, SYMBOL_WITH_POS_POS): New INLINE functions. * src/lread.c (read0, read1, read_list, read_vector, read_internal_start) (list2): Add a new bool parameter locate_syms. (Fread_positioning_symbols): New function. (Fread_from_string, read_internal_start, read0, read1, read_list): Pass around suitable values for locate_syms. (read1): Build symbols with position when locate_syms is true. * src/print.c (print_vectorlike): Add handling for PVEC_SYMBOL_WITH_POS. (print_object): Replace EQ with BASE_EQ. (print_symbols_bare): New boolean variable. --- lisp/emacs-lisp/byte-opt.el | 38 +-- lisp/emacs-lisp/bytecomp.el | 476 +++++++++++++++++++++++----------- lisp/emacs-lisp/cconv.el | 22 +- lisp/emacs-lisp/cl-generic.el | 4 +- lisp/emacs-lisp/cl-macs.el | 42 ++- lisp/emacs-lisp/eieio-core.el | 1 + lisp/emacs-lisp/eieio.el | 1 + lisp/emacs-lisp/gv.el | 5 +- lisp/emacs-lisp/macroexp.el | 8 +- lisp/emacs-lisp/pcase.el | 1 + src/.gdbinit | 12 + src/alloc.c | 40 ++- src/data.c | 81 ++++++ src/fns.c | 12 +- src/keyboard.c | 2 + src/lisp.h | 216 ++++++++++----- src/lread.c | 126 ++++++--- src/print.c | 33 ++- 18 files changed, 809 insertions(+), 311 deletions(-) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index f6db803b78e..7750f723ba0 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -264,8 +264,9 @@ Earlier variables shadow later ones with the same name.") (cdr (assq name byte-compile-function-environment))))) (pcase fn ('nil - (byte-compile-warn "attempt to inline `%s' before it was defined" - name) + (byte-compile-warn-x name + "attempt to inline `%s' before it was defined" + name) form) (`(autoload . ,_) (error "File `%s' didn't define `%s'" (nth 1 fn) name)) @@ -417,8 +418,8 @@ for speeding up processing.") (t form))) (`(quote . ,v) (if (or (not v) (cdr v)) - (byte-compile-warn "malformed quote form: `%s'" - (prin1-to-string form))) + (byte-compile-warn-x form "malformed quote form: `%s'" + form)) ;; Map (quote nil) to nil to simplify optimizer logic. ;; Map quoted constants to nil if for-effect (just because). (and (car v) @@ -436,8 +437,9 @@ for speeding up processing.") (cons (byte-optimize-form (car clause) nil) (byte-optimize-body (cdr clause) for-effect)) - (byte-compile-warn "malformed cond form: `%s'" - (prin1-to-string clause)) + (byte-compile-warn-x + clause "malformed cond form: `%s'" + clause) clause)) clauses))) (`(progn . ,exps) @@ -513,8 +515,7 @@ for speeding up processing.") `(while ,condition . ,body))) (`(interactive . ,_) - (byte-compile-warn "misplaced interactive spec: `%s'" - (prin1-to-string form)) + (byte-compile-warn-x form "misplaced interactive spec: `%s'" form) nil) (`(function . ,_) @@ -582,7 +583,7 @@ for speeding up processing.") (while args (unless (and (consp args) (symbolp (car args)) (consp (cdr args))) - (byte-compile-warn "malformed setq form: %S" form)) + (byte-compile-warn-x form "malformed setq form: %S" form)) (let* ((var (car args)) (expr (cadr args)) (lexvar (assq var byte-optimize--lexvars)) @@ -615,8 +616,7 @@ for speeding up processing.") (cons fn (mapcar #'byte-optimize-form exps))) (`(,(pred (not symbolp)) . ,_) - (byte-compile-warn "`%s' is a malformed function" - (prin1-to-string fn)) + (byte-compile-warn-x fn "`%s' is a malformed function" fn) form) ((guard (when for-effect @@ -624,8 +624,10 @@ for speeding up processing.") (or byte-compile-delete-errors (eq tmp 'error-free) (progn - (byte-compile-warn "value returned from %s is unused" - (prin1-to-string form)) + (byte-compile-warn-x + form + "value returned from %s is unused" + form) nil))))) (byte-compile-log " %s called for effect; deleted" fn) ;; appending a nil here might not be necessary, but it can't hurt. @@ -821,7 +823,8 @@ for speeding up processing.") (if (symbolp binding) binding (when (or (atom binding) (cddr binding)) - (byte-compile-warn "malformed let binding: `%S'" binding)) + (byte-compile-warn-x + binding "malformed let binding: `%S'" binding)) (list (car binding) (byte-optimize-form (nth 1 binding) nil)))) (car form)) @@ -1304,7 +1307,7 @@ See Info node `(elisp) Integer Basics'." (defun byte-optimize-while (form) (when (< (length form) 2) - (byte-compile-warn "too few arguments for `while'")) + (byte-compile-warn-x form "too few arguments for `while'")) (if (nth 1 form) form)) @@ -1342,9 +1345,10 @@ See Info node `(elisp) Integer Basics'." (let ((butlast (nreverse (cdr (reverse (cdr (cdr form))))))) (nconc (list 'funcall fn) butlast (mapcar (lambda (x) (list 'quote x)) (nth 1 last)))) - (byte-compile-warn + (byte-compile-warn-x + last "last arg to apply can't be a literal atom: `%s'" - (prin1-to-string last)) + last) nil)) form)))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 566a3fdf99c..869b6c01b8a 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -459,6 +459,42 @@ Filled in `cconv-analyze-form' but initialized and consulted here.") (defvar byte-compiler-error-flag) +(defvar byte-compile--form-stack nil + "Dynamic list of successive enclosing forms. +This is used by the warning message routines to determine a +source code position. The most accessible element is the current +most deeply nested form.") + +(defun byte-compile-strip-s-p-1 (arg) + "Strip all positions from symbols 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." @@ -467,7 +503,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) @@ -508,7 +545,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))) @@ -1212,6 +1250,41 @@ message buffer `default-directory'." (f2 (file-relative-name file dir))) (if (< (length f2) (length f1)) f2 f1))) +(defun byte-compile--first-symbol (form) + "Return the \"first\" symbol found in form, or 0 if there is none. +Here, \"first\" is by a depth first search." + (let (sym) + (cond + ((symbolp form) form) + ((consp form) + (or (and (symbolp (setq sym (byte-compile--first-symbol (car form)))) + sym) + (and (symbolp (setq sym (byte-compile--first-symbol (cdr form)))) + sym) + 0)) + ((and (vectorp form) + (> (length form) 0)) + (let ((i 0) + (len (length form)) + elt) + (catch 'sym + (while (< i len) + (when (symbolp + (setq elt (byte-compile--first-symbol (aref form i)))) + (throw 'sym elt)) + (setq i (1+ i))) + 0))) + (t 0)))) + +(defun byte-compile--warning-source-offset () + "Return a source offset from `byte-compile--form-stack'. +Return nil if such is not found." + (catch 'offset + (dolist (form byte-compile--form-stack) + (let ((s (byte-compile--first-symbol form))) + (if (symbol-with-pos-p s) + (throw 'offset (symbol-with-pos-pos s))))))) + ;; This is used as warning-prefix for the compiler. ;; It is always called with the warnings buffer current. (defun byte-compile-warning-prefix (level entry) @@ -1229,16 +1302,36 @@ message buffer `default-directory'." (format "%s:" (byte-compile-abbreviate-file load-file-name dir))) (t ""))) + (offset (byte-compile--warning-source-offset)) (pos (if (and byte-compile-current-file - (integerp byte-compile-read-position)) + (integerp byte-compile-read-position) + (or offset (not symbols-with-pos-enabled))) (with-current-buffer byte-compile-current-buffer - (format "%d:%d:" - (save-excursion - (goto-char byte-compile-last-position) - (1+ (count-lines (point-min) (point-at-bol)))) - (save-excursion - (goto-char byte-compile-last-position) - (1+ (current-column))))) + ;; (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")))) @@ -1342,11 +1435,25 @@ 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 format (apply #'format-message format args)) (if byte-compile-error-on-warn (error "%s" format) ; byte-compile-file catches and logs it (byte-compile-log-warning format t :warning))) +(defun byte-compile-warn-x (arg format &rest args) + "Issue a byte compiler warning. +ARG is the source element (likely a symbol with position) central to + the warning, intended to supply source position information. +FORMAT and ARGS are as in `byte-compile-warn'." + (let ((byte-compile--form-stack (cons arg byte-compile--form-stack))) + (apply #'byte-compile-warn format args))) + (defun byte-compile-warn-obsolete (symbol) "Warn that SYMBOL (a variable or function) is obsolete." (when (byte-compile-warning-enabled-p 'obsolete symbol) @@ -1356,7 +1463,7 @@ function directly; use `byte-compile-warn' or (or funcp (get symbol 'byte-obsolete-variable)) (if funcp "function" "variable")))) (unless (and funcp (memq symbol byte-compile-not-obsolete-funcs)) - (byte-compile-warn "%s" msg))))) + (byte-compile-warn-x symbol "%s" msg))))) (defun byte-compile-report-error (error-info &optional fill) "Report Lisp error in compilation. @@ -1481,7 +1588,8 @@ when printing the error message." (defun byte-compile-emit-callargs-warn (name actual-args min-args max-args) (byte-compile-set-symbol-position name) - (byte-compile-warn + (byte-compile-warn-x + name "%s called with %d argument%s, but %s %s" name actual-args (if (= 1 actual-args) "" "s") @@ -1547,7 +1655,7 @@ extra args." n))) (nargs (- (length form) 2))) (unless (= nargs nfields) - (byte-compile-warn + (byte-compile-warn-x (car form) "`%s' called with %d args to fill %d format field(s)" (car form) nargs nfields))))) @@ -1561,7 +1669,7 @@ extra args." (when (eq (car-safe name) 'quote) (or (not (eq (car form) 'custom-declare-variable)) (plist-get keyword-args :type) - (byte-compile-warn + (byte-compile-warn-x (cadr name) "defcustom for `%s' fails to specify type" (cadr name))) (if (and (memq (car form) '(custom-declare-face custom-declare-variable)) byte-compile-current-group) @@ -1570,7 +1678,7 @@ extra args." (or (and (eq (car form) 'custom-declare-group) (equal name ''emacs)) (plist-get keyword-args :group) - (byte-compile-warn + (byte-compile-warn-x (cadr name) "%s for `%s' fails to specify containing group" (cdr (assq (car form) '((custom-declare-group . defgroup) @@ -1589,7 +1697,7 @@ extra args." (let ((calls (assq name byte-compile-unresolved-functions)) nums sig min max) (when (and calls macrop) - (byte-compile-warn "macro `%s' defined too late" name)) + (byte-compile-warn-x name "macro `%s' defined too late" name)) (setq byte-compile-unresolved-functions (delq calls byte-compile-unresolved-functions)) (setq calls (delq t calls)) ;Ignore higher-order uses of the function. @@ -1597,8 +1705,8 @@ extra args." (when (and (symbolp name) (eq (function-get name 'byte-optimizer) 'byte-compile-inline-expand)) - (byte-compile-warn "defsubst `%s' was used before it was defined" - name)) + (byte-compile-warn-x name "defsubst `%s' was used before it was defined" + name)) (setq sig (byte-compile-arglist-signature arglist) nums (sort (copy-sequence (cddr calls)) (function <)) min (car nums) @@ -1606,7 +1714,8 @@ extra args." (when (or (< min (car sig)) (and (cdr sig) (> max (cdr sig)))) (byte-compile-set-symbol-position name) - (byte-compile-warn + (byte-compile-warn-x + name "%s being defined to take %s%s, but was previously called with %s" name (byte-compile-arglist-signature-string sig) @@ -1625,7 +1734,8 @@ extra args." (sig2 (byte-compile-arglist-signature arglist))) (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) (byte-compile-set-symbol-position name) - (byte-compile-warn + (byte-compile-warn-x + name "%s %s used to take %s %s, now takes %s" (if macrop "macro" "function") name @@ -1714,8 +1824,10 @@ It is too wide if it has any lines longer than the largest of (setq name (if name (format " `%s'" name) "")) (when (and kind docs (stringp docs) (byte-compile--wide-docstring-p docs col)) - (byte-compile-warn "%s%s docstring wider than %s characters" - kind name col)))) + (byte-compile-warn-x + name + "%s%s docstring wider than %s characters" + kind name col)))) form) ;; If we have compiled any calls to functions which are not known to be @@ -1730,7 +1842,8 @@ It is too wide if it has any lines longer than the largest of (let ((f (car urf))) (when (not (memq f byte-compile-new-defuns)) (let ((byte-compile-last-position (cadr urf))) - (byte-compile-warn + (byte-compile-warn-x + f (if (fboundp f) "the function `%s' might not be defined at runtime." "the function `%s' is not known to be defined.") (car urf)))))))) nil) @@ -2083,7 +2196,8 @@ See also `emacs-lisp-byte-compile-and-load'." ;; 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 @@ -2195,11 +2309,12 @@ With argument ARG, insert value in current buffer after the form." (byte-compile-last-warned-form 'nothing) (value (eval (let ((read-with-symbol-positions (current-buffer)) - (read-symbol-positions-list nil)) + (read-symbol-positions-list nil) + (symbols-with-pos-enabled t)) (displaying-byte-compile-warnings (byte-compile-sexp (eval-sexp-add-defvars - (read (current-buffer)) + (read-positioning-symbols (current-buffer)) byte-compile-read-position)))) lexical-binding))) (cond (arg @@ -2284,9 +2399,9 @@ With argument ARG, insert value in current buffer after the form." (setq byte-compile-read-position (point) byte-compile-last-position byte-compile-read-position) (let* ((lread--unescaped-character-literals nil) - (form (read inbuffer)) + (form (read-positioning-symbols inbuffer)) (warning (byte-run--unescaped-character-literals-warning))) - (when warning (byte-compile-warn "%s" warning)) + (when warning (byte-compile-warn-x form "%s" warning)) (byte-compile-toplevel-file-form form))) ;; Compile pending forms at end of file. (byte-compile-flush-pending) @@ -2496,7 +2611,8 @@ list that represents a doc string reference. byte-compile-jump-tables nil)))) (defun byte-compile-preprocess (form &optional _for-effect) - (setq form (macroexpand-all form byte-compile-macro-environment)) + (let ((print-symbols-bare t)) + (setq form (macroexpand-all form byte-compile-macro-environment))) ;; FIXME: We should run byte-optimize-form here, but it currently does not ;; recurse through all the code, so we'd have to fix this first. ;; Maybe a good fix would be to merge byte-optimize-form into @@ -2509,11 +2625,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) @@ -2546,7 +2664,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 @@ -2562,7 +2681,7 @@ list that represents a doc string reference. (delq (assq funsym byte-compile-unresolved-functions) byte-compile-unresolved-functions))))) (if (stringp (nth 3 form)) - (prog1 form + (prog1 (byte-compile-strip-symbol-positions form) (byte-compile-docstring-length-warn form)) ;; No doc string, so we can compile this as a normal form. (byte-compile-keep-pending form 'byte-compile-normal-call))) @@ -2574,7 +2693,8 @@ list that represents a doc string reference. (when (and (symbolp sym) (not (string-match "[-*/:$]" (symbol-name sym))) (byte-compile-warning-enabled-p 'lexical sym)) - (byte-compile-warn "global/dynamic var `%s' lacks a prefix" sym))) + (byte-compile-warn-x + sym "global/dynamic var `%s' lacks a prefix" sym))) (defun byte-compile--declare-var (sym) (byte-compile--check-prefixed-var sym) @@ -2582,7 +2702,7 @@ list that represents a doc string reference. (setq byte-compile-lexical-variables (delq sym byte-compile-lexical-variables)) (when (byte-compile-warning-enabled-p 'lexical sym) - (byte-compile-warn "Variable `%S' declared after its first use" sym))) + (byte-compile-warn-x sym "Variable `%S' declared after its first use" sym))) (push sym byte-compile-bound-variables) (push sym byte-compile--seen-defvars)) @@ -2595,10 +2715,17 @@ list that represents a doc string reference. (eq (car form) 'defvar)) ;Just a declaration. nil (byte-compile-docstring-length-warn form) + (setq form (copy-sequence form)) (cond ((consp (nth 2 form)) - (setq form (copy-sequence form)) (setcar (cdr (cdr form)) - (byte-compile-top-level (nth 2 form) nil 'file)))) + (byte-compile-top-level (nth 2 form) nil 'file))) + ((symbolp (nth 2 form)) + (setcar (cddr form) (bare-symbol (nth 2 form)))) + (t (setcar (cddr form) + (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 @@ -2616,7 +2743,8 @@ list that represents a doc string reference. (`(defvaralias ,_ ',newname . ,_) (when (memq newname byte-compile-bound-variables) (if (byte-compile-warning-enabled-p 'suspicious) - (byte-compile-warn + (byte-compile-warn-x + newname "Alias for `%S' should be declared before its referent" newname))))) (byte-compile-docstring-length-warn form) (byte-compile-keep-pending form)) @@ -2675,7 +2803,9 @@ list that represents a doc string reference. (put 'make-obsolete 'byte-hunk-handler 'byte-compile-file-form-make-obsolete) (defun byte-compile-file-form-make-obsolete (form) (prog1 (byte-compile-keep-pending form) - (apply 'make-obsolete (mapcar 'eval (cdr form))))) + (apply 'make-obsolete + (mapcar 'eval + (byte-compile-strip-symbol-positions (cdr form)))))) ;; This handler is not necessary, but it makes the output from dont-compile ;; and similar macros cleaner. @@ -2699,23 +2829,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 name) (byte-compile-arglist-warn name arglist macro)) (if byte-compile-verbose (message "Compiling %s... (%s)" - (or byte-compile-current-file "") name)) + (or byte-compile-current-file "") bare-name)) (cond ((not (or macro (listp body))) ;; We do not know positively if the definition is a macro ;; or a function, so we shouldn't emit warnings. @@ -2724,29 +2855,34 @@ not to take responsibility for the actual compilation of the code." (that-one (if (and (byte-compile-warning-enabled-p 'redefine name) ;; Don't warn when compiling the stubs in byte-run... - (not (assq name byte-compile-initial-macro-environment))) - (byte-compile-warn + (not (assq bare-name byte-compile-initial-macro-environment))) + (byte-compile-warn-x + name "`%s' defined multiple times, as both function and macro" - name)) + bare-name)) (setcdr that-one nil)) (this-one (when (and (byte-compile-warning-enabled-p 'redefine name) ;; Hack: Don't warn when compiling the magic internal ;; byte-compiler macros in byte-run.el... - (not (assq name byte-compile-initial-macro-environment))) - (byte-compile-warn "%s `%s' defined multiple times in this file" - (if macro "macro" "function") - name))) - ((eq (car-safe (symbol-function name)) + (not (assq bare-name byte-compile-initial-macro-environment))) + (byte-compile-warn-x + name + "%s `%s' defined multiple times in this file" + (if macro "macro" "function") + bare-name))) + ((eq (car-safe (symbol-function bare-name)) (if macro 'lambda 'macro)) - (when (byte-compile-warning-enabled-p 'redefine name) - (byte-compile-warn "%s `%s' being redefined as a %s" - (if macro "function" "macro") - name - (if macro "macro" "function"))) + (when (byte-compile-warning-enabled-p 'redefine bare-name) + (byte-compile-warn-x + name + "%s `%s' being redefined as a %s" + (if macro "function" "macro") + bare-name + (if macro "macro" "function"))) ;; Shadow existing definition. (set this-kind - (cons (cons name nil) + (cons (cons bare-name nil) (symbol-value this-kind)))) ) @@ -2757,8 +2893,8 @@ not to take responsibility for the actual compilation of the code." (stringp (car-safe (cdr-safe (cdr-safe body))))) ;; FIXME: We've done that already just above, so this looks wrong! ;;(byte-compile-set-symbol-position name) - (byte-compile-warn "probable `\"' without `\\' in doc string of %s" - name)) + (byte-compile-warn-x + name "probable `\"' without `\\' in doc string of %s" bare-name)) (if (not (listp body)) ;; The precise definition requires evaluation to find out, so it @@ -2766,7 +2902,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) @@ -2776,10 +2912,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 @@ -2806,7 +2942,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 @@ -2950,7 +3086,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." ((and (memq arg vars) ;; Allow repetitions for unused args. (not (string-match "\\`_" (symbol-name arg)))) - (byte-compile-warn "repeated variable %s in lambda-list" arg)) + (byte-compile-warn-x + arg "repeated variable %s in lambda-list" arg)) (t (push arg vars)))) (setq list (cdr list))))) @@ -2993,7 +3130,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (defun byte-compile--warn-lexical-dynamic (var context) (when (byte-compile-warning-enabled-p 'lexical-dynamic var) - (byte-compile-warn + (byte-compile-warn-x + var "`%s' lexically bound in %s here but declared dynamic in: %s" var context (mapconcat #'identity @@ -3045,8 +3183,8 @@ for symbols generated by the byte compiler itself." ;; Check that the bit after the `interactive' spec is ;; just a list of symbols (i.e., modes). (unless (seq-every-p #'symbolp (cdr (cdr int))) - (byte-compile-warn "malformed interactive specc: %s" - (prin1-to-string int))) + (byte-compile-warn-x int "malformed interactive specc: %s" + int)) (setq command-modes (cdr (cdr int))) ;; If the interactive spec is a call to `list', don't ;; compile it, because `call-interactively' looks at the @@ -3058,16 +3196,17 @@ for symbols generated by the byte compiler itself." (while (consp (cdr form)) (setq form (cdr form))) (setq form (car form))) - (when (or (not (eq (car-safe form) 'list)) - ;; For code using lexical-binding, form is not - ;; valid lisp, but rather an intermediate form - ;; which may include "calls" to - ;; internal-make-closure (Bug#29988). - lexical-binding) - (setq int `(interactive ,newform))))) + (if (or (not (eq (car-safe form) 'list)) + ;; For code using lexical-binding, form is not + ;; valid lisp, but rather an intermediate form + ;; which may include "calls" to + ;; internal-make-closure (Bug#29988). + lexical-binding) + (setq int (byte-compile-strip-symbol-positions `(interactive ,newform))) + (setq int (byte-compile-strip-symbol-positions int))))) ((cdr int) ; Invalid (interactive . something). - (byte-compile-warn "malformed interactive spec: %s" - (prin1-to-string int))))) + (byte-compile-warn-x int "malformed interactive spec: %s" + int)))) ;; Process the body. (let ((compiled (byte-compile-top-level (cons 'progn body) nil 'lambda @@ -3078,14 +3217,15 @@ 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))) (let ((out (apply #'make-byte-code (if lexical-binding (byte-compile-make-args-desc arglist) - arglist) + bare-arglist) (append ;; byte-string, constants-vector, stack depth (cdr compiled) @@ -3093,7 +3233,7 @@ for symbols generated by the byte compiler itself." (cond ((and lexical-binding arglist) ;; byte-compile-make-args-desc lost the args's names, ;; so preserve them in the docstring. - (list (help-add-fundoc-usage doc arglist))) + (list (help-add-fundoc-usage doc bare-arglist))) ((or doc int) (list doc))) ;; optionally, the interactive spec (and the modes the @@ -3101,7 +3241,9 @@ for symbols generated by the byte compiler itself." (cond ;; We have some command modes, so use the vector form. (command-modes - (list (vector (nth 1 int) command-modes))) + (list (vector (nth 1 int) + (byte-compile-strip-symbol-positions + command-modes)))) ;; No command modes, use the simple form with just the ;; interactive spec. (int @@ -3298,7 +3440,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 @@ -3315,19 +3458,21 @@ for symbols generated by the byte compiler itself." ;; byte-compile--for-effect flag too.) ;; (defun byte-compile-form (form &optional for-effect) - (let ((byte-compile--for-effect for-effect)) + (let ((byte-compile--for-effect for-effect) + (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)) @@ -3350,20 +3495,20 @@ for symbols generated by the byte compiler itself." (byte-compile-check-variable (cadr hook) nil)))) (when (and (byte-compile-warning-enabled-p 'suspicious) (macroexp--const-symbol-p fn)) - (byte-compile-warn "`%s' called as a function" fn)) + (byte-compile-warn-x fn "`%s' called as a function" fn)) (when (and (byte-compile-warning-enabled-p 'interactive-only fn) interactive-only) - (byte-compile-warn "`%s' is for interactive use only%s" - fn - (cond ((stringp interactive-only) - (format "; %s" - (substitute-command-keys - interactive-only))) - ((and (symbolp 'interactive-only) - (not (eq interactive-only t))) - (format-message "; use `%s' instead." - interactive-only)) - (t ".")))) + (byte-compile-warn-x fn "`%s' is for interactive use only%s" + fn + (cond ((stringp interactive-only) + (format "; %s" + (substitute-command-keys + interactive-only))) + ((and (symbolp 'interactive-only) + (not (eq interactive-only t))) + (format-message "; use `%s' instead." + interactive-only)) + (t ".")))) (if (eq (car-safe (symbol-function (car form))) 'macro) (byte-compile-report-error (format "`%s' defined after use in %S (missing `require' of a library file?)" @@ -3403,7 +3548,8 @@ for symbols generated by the byte compiler itself." (when (and byte-compile--for-effect (eq (car form) 'mapcar) (byte-compile-warning-enabled-p 'mapcar 'mapcar)) (byte-compile-set-symbol-position 'mapcar) - (byte-compile-warn + (byte-compile-warn-x + (car form) "`mapcar' called for effect; use `mapc' or `dolist' instead")) (byte-compile-push-constant (car form)) (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. @@ -3539,11 +3685,13 @@ for symbols generated by the byte compiler itself." (cond ((or (not (symbolp var)) (macroexp--const-symbol-p var)) (when (byte-compile-warning-enabled-p 'constants (and (symbolp var) var)) - (byte-compile-warn (if (eq access-type 'let-bind) - "attempt to let-bind %s `%s'" - "variable reference to %s `%s'") - (if (symbolp var) "constant" "nonvariable") - (prin1-to-string var)))) + (byte-compile-warn-x + var + (if (eq access-type 'let-bind) + "attempt to let-bind %s `%s'" + "variable reference to %s `%s'") + (if (symbolp var) "constant" "nonvariable") + var))) ((let ((od (get var 'byte-obsolete-variable))) (and od (not (memq var byte-compile-not-obsolete-vars)) @@ -3556,6 +3704,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)) @@ -3568,9 +3717,10 @@ for symbols generated by the byte compiler itself." (push var byte-compile-bound-variables) (byte-compile-dynamic-variable-op 'byte-varbind var)) -(defun byte-compile-free-vars-warn (var &optional assignment) +(defun byte-compile-free-vars-warn (arg var &optional assignment) "Warn if symbol VAR refers to a free variable. VAR must not be lexically bound. +ARG is a position argument, used by byte-compile-warn-x. If optional argument ASSIGNMENT is non-nil, this is treated as an assignment (i.e. `setq')." (unless (or (not (byte-compile-warning-enabled-p 'free-vars var)) @@ -3582,9 +3732,9 @@ assignment (i.e. `setq')." (let* ((varname (prin1-to-string var)) (desc (if assignment "assignment" "reference")) (suggestions (help-uni-confusable-suggestions varname))) - (byte-compile-warn "%s to free variable `%s'%s" - desc varname - (if suggestions (concat "\n " suggestions) ""))) + (byte-compile-warn-x arg "%s to free variable `%s'%s" + desc var + (if suggestions (concat "\n " suggestions) ""))) (push var (if assignment byte-compile-free-assignments byte-compile-free-references)))) @@ -3597,7 +3747,7 @@ assignment (i.e. `setq')." ;; VAR is lexically bound (byte-compile-stack-ref (cdr lex-binding)) ;; VAR is dynamically bound - (byte-compile-free-vars-warn var) + (byte-compile-free-vars-warn var var) (byte-compile-dynamic-variable-op 'byte-varref var)))) (defun byte-compile-variable-set (var) @@ -3608,7 +3758,7 @@ assignment (i.e. `setq')." ;; VAR is lexically bound. (byte-compile-stack-set (cdr lex-binding)) ;; VAR is dynamically bound. - (byte-compile-free-vars-warn var t) + (byte-compile-free-vars-warn var var t) (byte-compile-dynamic-variable-op 'byte-varset var)))) (defmacro byte-compile-get-constant (const) @@ -3628,14 +3778,19 @@ assignment (i.e. `setq')." (defun byte-compile-constant (const) (if byte-compile--for-effect (setq byte-compile--for-effect nil) - (inline (byte-compile-push-constant const)))) + (inline (byte-compile-push-constant + (if (symbolp const) (bare-symbol const) const))))) ;; Use this for a constant that is not the value of its containing form. ;; This ignores byte-compile--for-effect. (defun byte-compile-push-constant (const) (when (symbolp const) - (byte-compile-set-symbol-position const)) - (byte-compile-out 'byte-constant (byte-compile-get-constant const))) + (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. @@ -3788,9 +3943,10 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (defun byte-compile-subr-wrong-args (form n) (byte-compile-set-symbol-position (car form)) - (byte-compile-warn "`%s' called with %d arg%s, but requires %s" - (car form) (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s") n) + (byte-compile-warn-x (car form) + "`%s' called with %d arg%s, but requires %s" + (car form) (length (cdr form)) + (if (= 1 (length (cdr form))) "" "s") n) ;; Get run-time wrong-number-of-args error. (byte-compile-normal-call form)) @@ -4099,7 +4255,8 @@ discarding." (if (eq 'interactive (car-safe (car body))) (setq body (cdr body))) (if (and (consp (car body)) (not (eq 'byte-code (car (car body))))) - (byte-compile-warn + (byte-compile-warn-x + (nth 2 form) "A quoted lambda form is the second argument of `fset'. This is probably not what you want, as that lambda cannot be compiled. Consider using the syntax #'(lambda (...) ...) instead."))))) @@ -4184,10 +4341,11 @@ discarding." (macroexp--const-symbol-p var t)) (byte-compile-warning-enabled-p 'constants (and (symbolp var) var)) - (byte-compile-warn + (byte-compile-warn-x + var "variable assignment to %s `%s'" (if (symbolp var) "constant" "nonvariable") - (prin1-to-string var))))) + var)))) (byte-compile-normal-call form))) (defun byte-compile-quote (form) @@ -4466,7 +4624,7 @@ Return (TAIL VAR TEST CASES), where: (dolist (case cases) (setq tag (byte-compile-make-tag) - test-objects (car case) + test-objects (byte-compile-strip-symbol-positions (car case)) body (cdr case)) (byte-compile-out-tag tag) (dolist (value test-objects) @@ -4772,16 +4930,16 @@ binding slots have been popped." (endtag (byte-compile-make-tag))) (byte-compile-set-symbol-position 'condition-case) (unless (symbolp var) - (byte-compile-warn - "`%s' is not a variable-name or nil (in condition-case)" var)) + (byte-compile-warn-x + var "`%s' is not a variable-name or nil (in condition-case)" var)) (dolist (clause (reverse clauses)) (let ((condition (nth 1 clause))) (unless (consp condition) (setq condition (list condition))) (dolist (c condition) (unless (and c (symbolp c)) - (byte-compile-warn - "`%S' is not a condition name (in condition-case)" c)) + (byte-compile-warn-x + c "`%S' is not a condition name (in condition-case)" c)) ;; In reality, the `error-conditions' property is only required ;; for the argument to `signal', not to `condition-case'. ;;(unless (consp (get c 'error-conditions)) @@ -4832,7 +4990,8 @@ binding slots have been popped." (defun byte-compile-save-excursion (form) (if (and (eq 'set-buffer (car-safe (car-safe (cdr form)))) (byte-compile-warning-enabled-p 'suspicious 'set-buffer)) - (byte-compile-warn + (byte-compile-warn-x + form "Use `with-current-buffer' rather than save-excursion+set-buffer")) (byte-compile-out 'byte-save-excursion 0) (byte-compile-body-do-effect (cdr form)) @@ -4873,8 +5032,10 @@ binding slots have been popped." (when (and (symbolp (nth 1 form)) (not (string-match "[-*/:$]" (symbol-name (nth 1 form)))) (byte-compile-warning-enabled-p 'lexical (nth 1 form))) - (byte-compile-warn "global/dynamic var `%s' lacks a prefix" - (nth 1 form))) + (byte-compile-warn-x + (nth 1 form) + "global/dynamic var `%s' lacks a prefix" + (nth 1 form))) (byte-compile-docstring-length-warn form) (let ((fun (nth 0 form)) (var (nth 1 form)) @@ -4884,7 +5045,8 @@ binding slots have been popped." (when (or (> (length form) 4) (and (eq fun 'defconst) (null (cddr form)))) (let ((ncall (length (cdr form)))) - (byte-compile-warn + (byte-compile-warn-x + fun "`%s' called with %d argument%s, but %s %s" fun ncall (if (= 1 ncall) "" "s") @@ -4894,8 +5056,10 @@ binding slots have been popped." (if (eq fun 'defconst) (push var byte-compile-const-variables)) (when (and string (not (stringp string))) - (byte-compile-warn "third arg to `%s %s' is not a string: %s" - fun var string)) + (byte-compile-warn-x + string + "third arg to `%s %s' is not a string: %s" + fun var string)) (byte-compile-form-do-effect (if (cddr form) ; `value' provided ;; Quote with `quote' to prevent byte-compiling the body, @@ -4915,7 +5079,8 @@ binding slots have been popped." (macroexp-const-p (nth 5 form)) (memq (eval (nth 5 form)) '(t macro)) ; macro-p (not (fboundp (eval (nth 1 form)))) - (byte-compile-warn + (byte-compile-warn-x + form "The compiler ignores `autoload' except at top level. You should probably put the autoload of the macro `%s' at top-level." (eval (nth 1 form)))) @@ -5004,7 +5169,8 @@ binding slots have been popped." (defun byte-compile-make-variable-buffer-local (form) (if (and (eq (car-safe (car-safe (cdr-safe form))) 'quote) (byte-compile-warning-enabled-p 'make-local)) - (byte-compile-warn + (byte-compile-warn-x + form "`make-variable-buffer-local' not called at toplevel")) (byte-compile-normal-call form)) (put 'make-variable-buffer-local @@ -5062,7 +5228,7 @@ binding slots have been popped." (when (or (vectorp key) (and (stringp key) (not (key-valid-p key)))) - (byte-compile-warn "Invalid `kbd' syntax: %S" key)))) + (byte-compile-warn-x form "Invalid `kbd' syntax: %S" key)))) form))) ;; Functions and the place(s) for the key definition(s). '((keymap-set 2) @@ -5088,23 +5254,23 @@ binding slots have been popped." (not (eq (car form) :menu))) (unless (memq (car form) '(:full :keymap :parent :suppress :name :prefix)) - (byte-compile-warn "Invalid keyword: %s" (car form))) + (byte-compile-warn-x (car form) "Invalid keyword: %s" (car form))) (push (pop form) result) (when (null form) - (byte-compile-warn "Uneven number of keywords in %S" form)) + (byte-compile-warn-x orig-form "Uneven number of keywords in %S" form)) (push (pop form) result)) ;; Bindings. (while form (let ((key (pop form))) (when (stringp key) (unless (key-valid-p key) - (byte-compile-warn "Invalid `kbd' syntax: %S" key))) + (byte-compile-warn-x form "Invalid `kbd' syntax: %S" key))) ;; No improvement. (push key result)) (when (null form) - (byte-compile-warn "Uneven number of key bindings in %S" form)) + (byte-compile-warn-x form "Uneven number of key bindings in %S" form)) (push (pop form) result)) - orig-form)) + (byte-compile-strip-symbol-positions orig-form))) (put 'define-keymap--define 'byte-hunk-handler #'byte-compile-define-keymap--define) @@ -5171,24 +5337,26 @@ OP and OPERAND are as passed to `byte-compile-out'." ;;; call tree stuff (defun byte-compile-annotate-call-tree (form) - (let (entry) + (let ((current-form (byte-compile-strip-symbol-positions + byte-compile-current-form)) + (bare-car-form (byte-compile-strip-symbol-positions (car form))) + entry) ;; annotate the current call - (if (setq entry (assq (car form) byte-compile-call-tree)) - (or (memq byte-compile-current-form (nth 1 entry)) ;callers + (if (setq entry (assq bare-car-form byte-compile-call-tree)) + (or (memq current-form (nth 1 entry)) ;callers (setcar (cdr entry) - (cons byte-compile-current-form (nth 1 entry)))) + (cons current-form (nth 1 entry)))) (setq byte-compile-call-tree - (cons (list (car form) (list byte-compile-current-form) nil) + (cons (list bare-car-form (list current-form) nil) byte-compile-call-tree))) ;; annotate the current function - (if (setq entry (assq byte-compile-current-form byte-compile-call-tree)) - (or (memq (car form) (nth 2 entry)) ;called + (if (setq entry (assq current-form byte-compile-call-tree)) + (or (memq bare-car-form (nth 2 entry)) ;called (setcar (cdr (cdr entry)) - (cons (car form) (nth 2 entry)))) + (cons bare-car-form (nth 2 entry)))) (setq byte-compile-call-tree - (cons (list byte-compile-current-form nil (list (car form))) - byte-compile-call-tree))) - )) + (cons (list current-form nil (list bare-car-form)) + byte-compile-call-tree))))) ;; Renamed from byte-compile-report-call-tree ;; to avoid interfering with completion of byte-compile-file. @@ -5213,14 +5381,15 @@ invoked interactively." (set-buffer "*Call-Tree*") (erase-buffer) (message "Generating call tree... (sorting on %s)" - byte-compile-call-tree-sort) + (remove-pos-from-symbol byte-compile-call-tree-sort)) (insert "Call tree for " (cond ((null byte-compile-current-file) (or filename "???")) ((stringp byte-compile-current-file) byte-compile-current-file) (t (buffer-name byte-compile-current-file))) " sorted on " - (prin1-to-string byte-compile-call-tree-sort) + (prin1-to-string (remove-pos-from-symbol + byte-compile-call-tree-sort)) ":\n\n") (if byte-compile-call-tree-sort (setq byte-compile-call-tree @@ -5240,7 +5409,8 @@ invoked interactively." ('name (lambda (x y) (string< (car x) (car y)))) (_ (error "`byte-compile-call-tree-sort': `%s' - unknown sort mode" - byte-compile-call-tree-sort)))))) + (remove-pos-from-symbol + byte-compile-call-tree-sort))))))) (message "Generating call tree...") (let ((rest byte-compile-call-tree) (b (current-buffer)) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 03e109f2508..9c9ebe15d5d 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -353,7 +353,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)) @@ -361,9 +362,9 @@ places where they originally did not directly appear." (cond ;; Ignore bindings without a valid name. ((not (symbolp var)) - (byte-compile-warn "attempt to let-bind nonvariable `%S'" var)) + (byte-compile-warn-x var "attempt to let-bind nonvariable `%S'" var)) ((or (booleanp var) (keywordp var)) - (byte-compile-warn "attempt to let-bind constant `%S'" var)) + (byte-compile-warn-x var "attempt to let-bind constant `%S'" var)) (t (let ((new-val (pcase (cconv--var-classification binder form) @@ -610,7 +611,8 @@ FORM is the parent form that binds this var." ;; FIXME: Convert this warning to use `macroexp--warn-wrap' ;; so as to give better position information. (when (byte-compile-warning-enabled-p 'not-unused var) - (byte-compile-warn "%s `%S' not left unused" varkind var))) + (byte-compile-warn-x + var "%s `%S' not left unused" varkind var))) ((and (let (or 'let* 'let) (car form)) `((,var) ;; (or `(,var nil) : Too many false positives: bug#47080 t nil ,_ ,_)) @@ -618,7 +620,7 @@ FORM is the parent form that binds this var." ;; so as to give better position information and obey ;; `byte-compile-warnings'. (unless (not (intern-soft var)) - (byte-compile-warn "Variable `%S' left uninitialized" var)))) + (byte-compile-warn-x var "Variable `%S' left uninitialized" var)))) (pcase vardata (`(,binder nil ,_ ,_ nil) (push (cons (cons binder form) :unused) cconv-var-classification)) @@ -647,7 +649,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, ... @@ -730,7 +733,8 @@ This function does not return anything but instead fills the (setq forms (cddr forms)))) (`((lambda . ,_) . ,_) ; First element is lambda expression. - (byte-compile-warn + (byte-compile-warn-x + (nth 1 (car form)) "Use of deprecated ((lambda %s ...) ...) form" (nth 1 (car form))) (dolist (exp `((function ,(car form)) . ,(cdr form))) (cconv-analyze-form exp env))) @@ -749,8 +753,8 @@ This function does not return anything but instead fills the (`(condition-case ,var ,protected-form . ,handlers) (cconv-analyze-form protected-form env) (when (and var (symbolp var) (byte-compile-not-lexical-var-p var)) - (byte-compile-warn - "Lexical variable shadows the dynamic variable %S" var)) + (byte-compile-warn-x + var "Lexical variable shadows the dynamic variable %S" var)) (let* ((varstruct (list var nil nil nil nil))) (if var (push varstruct env)) (dolist (handler handlers) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 9de47e4987d..b94737e0fee 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -496,7 +496,8 @@ The set of acceptable TYPEs (also called \"specializers\") is defined cl--generic-edebug-make-name nil] lambda-doc ; documentation string def-body))) ; part to be debugged - (let ((qualifiers nil)) + (let ((qualifiers nil) + (org-name name)) (while (cl-generic--method-qualifier-p args) (push args qualifiers) (setq args (pop body))) @@ -511,6 +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 (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 1852471bcbb..dbe0eb1b0e2 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) @@ -2417,10 +2447,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))))) @@ -3104,6 +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)) (format "Missing value for option `%S' of slot `%s' in struct %s!" (car (last desc)) slot name) 'nil) @@ -3113,6 +3146,7 @@ To see the documentation for a defined struct type, use (let ((kw (car defaults))) (push (macroexp-warn-and-return + ;; kw (format " I'll take `%s' to be an option rather than a default value." kw) 'nil) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 7c5babcf54c..4e9357c2ada 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -744,6 +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 (format-message "Unknown slot `%S'" name) exp nil 'compile-only)) (_ exp)))) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 3fbfe011e29..76f7b661a62 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -292,6 +292,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 ebcc63cc2a5..ed33524f2dc 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -581,7 +581,9 @@ This is like the `&' operator of the C language. Note: this only works reliably with lexical binding mode, except for very simple PLACEs such as (symbol-function \\='foo) which will also work in dynamic binding mode." - (let ((code + (let ((org-place place) ; It's too difficult to determine by inspection whether + ; the functions modify place. + (code (gv-letplace (getter setter) place `(cons (lambda () ,getter) (lambda (gv--val) ,(funcall setter 'gv--val)))))) @@ -593,6 +595,7 @@ binding mode." (eq (car-safe code) 'cons)) code (macroexp-warn-and-return + ;; org-place "Use of gv-ref probably requires lexical-binding" code)))) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 1e4fdd126cb..6d114a8a547 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -138,14 +138,15 @@ Other uses risk returning non-nil value that point to the wrong file." (defun macroexp--warn-wrap (msg form category) (let ((when-compiled (lambda () (when (byte-compile-warning-enabled-p category) - (byte-compile-warn "%s" msg))))) + (byte-compile-warn-x form "%s" msg))))) `(progn (macroexp--funcall-if-compiled ',when-compiled) ,form))) (define-obsolete-function-alias 'macroexp--warn-and-return #'macroexp-warn-and-return "28.1") -(defun macroexp-warn-and-return (msg form &optional category compile-only) +(defun macroexp-warn-and-return (;; _arg + msg form &optional category compile-only) "Return code equivalent to FORM labeled with warning MSG. CATEGORY is the category of the warning, like the categories that can appear in `byte-compile-warnings'. @@ -216,6 +217,7 @@ is executed without being compiled first." (let* ((fun (car form)) (obsolete (get fun 'byte-obsolete-info))) (macroexp-warn-and-return + ;; fun (macroexp--obsolete-warning fun obsolete (if (symbolp (symbol-function fun)) @@ -330,6 +332,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (if (null body) (macroexp-unprogn (macroexp-warn-and-return + ;; fun (format "Empty %s body" fun) nil nil 'compile-only)) (macroexp--all-forms body)) @@ -367,6 +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) (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 a3498d2da8d..430ae97078c 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -940,6 +940,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/.gdbinit b/src/.gdbinit index f74e295f7ea..9f2a86b779d 100644 --- a/src/.gdbinit +++ b/src/.gdbinit @@ -746,6 +746,15 @@ Print $ as a overlay pointer. This command assumes that $ is an Emacs Lisp overlay value. end +define xsymwithpos + xgetptr $ + print (struct Lisp_Symbol_With_Pos *) $ptr +end +document xsymwithpos +Print $ as a symbol with position. +This command assumes that $ is an Emacs Lisp symbol with position value. +end + define xsymbol set $sym = $ xgetsym $sym @@ -1011,6 +1020,9 @@ define xpr if $vec == PVEC_OVERLAY xoverlay end + if $vec == PVEC_SYMBOL_WITH_POS + xsymwithpos + end if $vec == PVEC_PROCESS xprocess end diff --git a/src/alloc.c b/src/alloc.c index f8908c91dba..0d69f23048a 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -591,7 +591,7 @@ pointer_align (void *ptr, int alignment) static ATTRIBUTE_NO_SANITIZE_UNDEFINED void * XPNTR (Lisp_Object a) { - return (SYMBOLP (a) + return (BARE_SYMBOL_P (a) ? (char *) lispsym + (XLI (a) - LISP_WORD_TAG (Lisp_Symbol)) : (char *) XLP (a) - (XLI (a) & ~VALMASK)); } @@ -3598,13 +3598,13 @@ static struct Lisp_Symbol *symbol_free_list; static void set_symbol_name (Lisp_Object sym, Lisp_Object name) { - XSYMBOL (sym)->u.s.name = name; + XBARE_SYMBOL (sym)->u.s.name = name; } void init_symbol (Lisp_Object val, Lisp_Object name) { - struct Lisp_Symbol *p = XSYMBOL (val); + struct Lisp_Symbol *p = XBARE_SYMBOL (val); set_symbol_name (val, name); set_symbol_plist (val, Qnil); p->u.s.redirect = SYMBOL_PLAINVAL; @@ -3667,6 +3667,21 @@ make_misc_ptr (void *a) return make_lisp_ptr (p, Lisp_Vectorlike); } +/* Return a new symbol with position with the specified SYMBOL and POSITION. */ +Lisp_Object +build_symbol_with_pos (Lisp_Object symbol, Lisp_Object position) +{ + Lisp_Object val; + struct Lisp_Symbol_With_Pos *p + = (struct Lisp_Symbol_With_Pos *) allocate_vector (2); + XSETVECTOR (val, p); + XSETPVECTYPESIZE (XVECTOR (val), PVEC_SYMBOL_WITH_POS, 2, 0); + p->sym = symbol; + p->pos = position; + + return val; +} + /* Return a new overlay with specified START, END and PLIST. */ Lisp_Object @@ -5210,7 +5225,7 @@ valid_lisp_object_p (Lisp_Object obj) if (PURE_P (p)) return 1; - if (SYMBOLP (obj) && c_symbol_p (p)) + if (BARE_SYMBOL_P (obj) && c_symbol_p (p)) return ((char *) p - (char *) lispsym) % sizeof lispsym[0] == 0; if (p == &buffer_defaults || p == &buffer_local_symbols) @@ -5638,12 +5653,12 @@ purecopy (Lisp_Object obj) vec->contents[i] = purecopy (vec->contents[i]); XSETVECTOR (obj, vec); } - else if (SYMBOLP (obj)) + else if (BARE_SYMBOL_P (obj)) { - if (!XSYMBOL (obj)->u.s.pinned && !c_symbol_p (XSYMBOL (obj))) + if (!XBARE_SYMBOL (obj)->u.s.pinned && !c_symbol_p (XBARE_SYMBOL (obj))) { /* We can't purify them, but they appear in many pure objects. Mark them as `pinned' so we know to mark them at every GC cycle. */ - XSYMBOL (obj)->u.s.pinned = true; + XBARE_SYMBOL (obj)->u.s.pinned = true; symbol_block_pinned = symbol_block; } /* Don't hash-cons it. */ @@ -6268,7 +6283,10 @@ For further details, see Info node `(elisp)Garbage Collection'. */) if (garbage_collection_inhibited) return Qnil; + ptrdiff_t count = SPECPDL_INDEX (); + specbind (Qsymbols_with_pos_enabled, Qnil); garbage_collect (); + unbind_to (count, Qnil); struct gcstat gcst = gcstat; Lisp_Object total[] = { @@ -6407,7 +6425,7 @@ mark_char_table (struct Lisp_Vector *ptr, enum pvec_type pvectype) Lisp_Object val = ptr->contents[i]; if (FIXNUMP (val) || - (SYMBOLP (val) && symbol_marked_p (XSYMBOL (val)))) + (BARE_SYMBOL_P (val) && symbol_marked_p (XBARE_SYMBOL (val)))) continue; if (SUB_CHAR_TABLE_P (val)) { @@ -6809,7 +6827,7 @@ mark_object (Lisp_Object arg) case Lisp_Symbol: { - struct Lisp_Symbol *ptr = XSYMBOL (obj); + struct Lisp_Symbol *ptr = XBARE_SYMBOL (obj); nextsym: if (symbol_marked_p (ptr)) break; @@ -6930,7 +6948,7 @@ survives_gc_p (Lisp_Object obj) break; case Lisp_Symbol: - survives_p = symbol_marked_p (XSYMBOL (obj)); + survives_p = symbol_marked_p (XBARE_SYMBOL (obj)); break; case Lisp_String: @@ -7347,7 +7365,7 @@ arenas. */) static bool symbol_uses_obj (Lisp_Object symbol, Lisp_Object obj) { - struct Lisp_Symbol *sym = XSYMBOL (symbol); + struct Lisp_Symbol *sym = XBARE_SYMBOL (symbol); Lisp_Object val = find_symbol_value (symbol); return (EQ (val, obj) || EQ (sym->u.s.function, obj) diff --git a/src/data.c b/src/data.c index 0d3376f0903..b3b157a7f39 100644 --- a/src/data.c +++ b/src/data.c @@ -216,6 +216,7 @@ for example, (type-of 1) returns `integer'. */) case PVEC_NORMAL_VECTOR: return Qvector; case PVEC_BIGNUM: return Qinteger; case PVEC_MARKER: return Qmarker; + case PVEC_SYMBOL_WITH_POS: return Qsymbol_with_pos; case PVEC_OVERLAY: return Qoverlay; case PVEC_FINALIZER: return Qfinalizer; case PVEC_USER_PTR: return Quser_ptr; @@ -316,6 +317,26 @@ DEFUN ("nlistp", Fnlistp, Snlistp, 1, 1, 0, return Qt; } +DEFUN ("bare-symbol-p", Fbare_symbol_p, Sbare_symbol_p, 1, 1, 0, + doc: /* Return t if OBJECT is a symbol, but not a symbol together with position. */ + attributes: const) + (Lisp_Object object) +{ + if (BARE_SYMBOL_P (object)) + return Qt; + return Qnil; +} + +DEFUN ("symbol-with-pos-p", Fsymbol_with_pos_p, Ssymbol_with_pos_p, 1, 1, 0, + doc: /* Return t if OBJECT is a symbol together with position. */ + attributes: const) + (Lisp_Object object) +{ + if (SYMBOL_WITH_POS_P (object)) + return Qt; + return Qnil; +} + DEFUN ("symbolp", Fsymbolp, Ssymbolp, 1, 1, 0, doc: /* Return t if OBJECT is a symbol. */ attributes: const) @@ -753,6 +774,51 @@ DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, return name; } +DEFUN ("bare-symbol", Fbare_symbol, Sbare_symbol, 1, 1, 0, + doc: /* Extract, if need be, the bare symbol from SYM, a symbol. */) + (register Lisp_Object sym) +{ + if (BARE_SYMBOL_P (sym)) + return sym; + /* Type checking is done in the following macro. */ + return SYMBOL_WITH_POS_SYM (sym); +} + +DEFUN ("symbol-with-pos-pos", Fsymbol_with_pos_pos, Ssymbol_with_pos_pos, 1, 1, 0, + doc: /* Extract the position from a symbol with position. */) + (register Lisp_Object ls) +{ + /* Type checking is done in the following macro. */ + return SYMBOL_WITH_POS_POS (ls); +} + +DEFUN ("position-symbol", Fposition_symbol, Sposition_symbol, 2, 2, 0, + doc: /* Create a new symbol with position. +SYM is a symbol, with or without position, the symbol to position. +POS, the position, is either a fixnum or a symbol with position from which +the position will be taken. */) + (register Lisp_Object sym, register Lisp_Object pos) +{ + Lisp_Object bare; + Lisp_Object position; + + if (BARE_SYMBOL_P (sym)) + bare = sym; + else if (SYMBOL_WITH_POS_P (sym)) + bare = XSYMBOL_WITH_POS (sym)->sym; + else + wrong_type_argument (Qsymbolp, sym); + + if (FIXNUMP (pos)) + position = pos; + else if (SYMBOL_WITH_POS_P (pos)) + position = XSYMBOL_WITH_POS (pos)->pos; + else + wrong_type_argument (Qfixnum_or_symbol_with_pos_p, pos); + + return build_symbol_with_pos (bare, position); +} + DEFUN ("fset", Ffset, Sfset, 2, 2, 0, doc: /* Set SYMBOL's function definition to DEFINITION, and return DEFINITION. */) (register Lisp_Object symbol, Lisp_Object definition) @@ -3929,6 +3995,8 @@ syms_of_data (void) DEFSYM (Qlistp, "listp"); DEFSYM (Qconsp, "consp"); + DEFSYM (Qbare_symbol_p, "bare-symbol-p"); + DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p"); DEFSYM (Qsymbolp, "symbolp"); DEFSYM (Qfixnump, "fixnump"); DEFSYM (Qintegerp, "integerp"); @@ -3954,6 +4022,7 @@ syms_of_data (void) DEFSYM (Qchar_table_p, "char-table-p"); DEFSYM (Qvector_or_char_table_p, "vector-or-char-table-p"); + DEFSYM (Qfixnum_or_symbol_with_pos_p, "fixnum-or-symbol-with-pos-p"); DEFSYM (Qsubrp, "subrp"); DEFSYM (Qunevalled, "unevalled"); @@ -4038,6 +4107,7 @@ syms_of_data (void) DEFSYM (Qstring, "string"); DEFSYM (Qcons, "cons"); DEFSYM (Qmarker, "marker"); + DEFSYM (Qsymbol_with_pos, "symbol-with-pos"); DEFSYM (Qoverlay, "overlay"); DEFSYM (Qfinalizer, "finalizer"); DEFSYM (Qmodule_function, "module-function"); @@ -4089,6 +4159,8 @@ syms_of_data (void) defsubr (&Snumber_or_marker_p); defsubr (&Sfloatp); defsubr (&Snatnump); + defsubr (&Sbare_symbol_p); + defsubr (&Ssymbol_with_pos_p); defsubr (&Ssymbolp); defsubr (&Skeywordp); defsubr (&Sstringp); @@ -4119,6 +4191,9 @@ syms_of_data (void) defsubr (&Sindirect_function); defsubr (&Ssymbol_plist); defsubr (&Ssymbol_name); + defsubr (&Sbare_symbol); + defsubr (&Ssymbol_with_pos_pos); + defsubr (&Sposition_symbol); defsubr (&Smakunbound); defsubr (&Sfmakunbound); defsubr (&Sboundp); @@ -4201,6 +4276,12 @@ This variable cannot be set; trying to do so will signal an error. */); Vmost_negative_fixnum = make_fixnum (MOST_NEGATIVE_FIXNUM); make_symbol_constant (intern_c_string ("most-negative-fixnum")); + DEFSYM (Qsymbols_with_pos_enabled, "symbols-with-pos-enabled"); + DEFVAR_BOOL ("symbols-with-pos-enabled", symbols_with_pos_enabled, + doc: /* Non-nil when "symbols with position" can be used as symbols. +Bind this to non-nil in applications such as the byte compiler. */); + symbols_with_pos_enabled = false; + DEFSYM (Qwatchers, "watchers"); DEFSYM (Qmakunbound, "makunbound"); DEFSYM (Qunlet, "unlet"); diff --git a/src/fns.c b/src/fns.c index 76c76c92ba9..43df40aa9ed 100644 --- a/src/fns.c +++ b/src/fns.c @@ -2569,6 +2569,13 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, } } + /* A symbol with position compares the contained symbol, and is + `equal' to the corresponding ordinary symbol. */ + if (SYMBOL_WITH_POS_P (o1)) + o1 = SYMBOL_WITH_POS_SYM (o1); + if (SYMBOL_WITH_POS_P (o2)) + o2 = SYMBOL_WITH_POS_SYM (o2); + if (EQ (o1, o2)) return true; if (XTYPE (o1) != XTYPE (o2)) @@ -4479,7 +4486,10 @@ hash_lookup (struct Lisp_Hash_Table *h, Lisp_Object key, Lisp_Object *hash) { ptrdiff_t start_of_bucket, i; - Lisp_Object hash_code = h->test.hashfn (key, h); + Lisp_Object hash_code; + if (SYMBOL_WITH_POS_P (key)) + key = SYMBOL_WITH_POS_SYM (key); + hash_code = h->test.hashfn (key, h); if (hash) *hash = hash_code; diff --git a/src/keyboard.c b/src/keyboard.c index c98175aea0d..050537b95cf 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -688,6 +688,8 @@ recursive_edit_1 (void) { specbind (Qstandard_output, Qt); specbind (Qstandard_input, Qt); + specbind (Qsymbols_with_pos_enabled, Qnil); + specbind (Qprint_symbols_bare, Qnil); } #ifdef HAVE_WINDOW_SYSTEM diff --git a/src/lisp.h b/src/lisp.h index 19caba40014..08013e94d16 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -364,18 +364,38 @@ typedef EMACS_INT Lisp_Word; # endif #endif +#define lisp_h_PSEUDOVECTORP(a,code) \ + (lisp_h_VECTORLIKEP((a)) && \ + ((XUNTAG ((a), Lisp_Vectorlike, union vectorlike_header)->size \ + & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) \ + == (PSEUDOVECTOR_FLAG | ((code) << PSEUDOVECTOR_AREA_BITS)))) + #define lisp_h_CHECK_FIXNUM(x) CHECK_TYPE (FIXNUMP (x), Qfixnump, x) #define lisp_h_CHECK_SYMBOL(x) CHECK_TYPE (SYMBOLP (x), Qsymbolp, x) #define lisp_h_CHECK_TYPE(ok, predicate, x) \ ((ok) ? (void) 0 : wrong_type_argument (predicate, x)) #define lisp_h_CONSP(x) TAGGEDP (x, Lisp_Cons) -#define lisp_h_EQ(x, y) (XLI (x) == XLI (y)) +#define lisp_h_BASE_EQ(x, y) (XLI (x) == XLI (y)) +/* #define lisp_h_EQ(x, y) (XLI (x) == XLI (y)) */ + +#define lisp_h_EQ(x, y) ((XLI ((x)) == XLI ((y))) \ + || (symbols_with_pos_enabled \ + && (SYMBOL_WITH_POS_P ((x)) \ + ? BARE_SYMBOL_P ((y)) \ + ? (XSYMBOL_WITH_POS((x)))->sym == (y) \ + : SYMBOL_WITH_POS_P((y)) \ + && ((XSYMBOL_WITH_POS((x)))->sym \ + == (XSYMBOL_WITH_POS((y)))->sym) \ + : (SYMBOL_WITH_POS_P ((y)) \ + && BARE_SYMBOL_P ((x)) \ + && ((x) == ((XSYMBOL_WITH_POS ((y)))->sym)))))) + #define lisp_h_FIXNUMP(x) \ (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \ - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) \ & ((1 << INTTYPEBITS) - 1))) #define lisp_h_FLOATP(x) TAGGEDP (x, Lisp_Float) -#define lisp_h_NILP(x) EQ (x, Qnil) +#define lisp_h_NILP(x) /* x == Qnil */ /* ((XLI (x) == XLI (Qnil))) */ /* EQ (x, Qnil) */ BASE_EQ (x, Qnil) #define lisp_h_SET_SYMBOL_VAL(sym, v) \ (eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), \ (sym)->u.s.val.value = (v)) @@ -384,7 +404,10 @@ typedef EMACS_INT Lisp_Word; #define lisp_h_SYMBOL_TRAPPED_WRITE_P(sym) (XSYMBOL (sym)->u.s.trapped_write) #define lisp_h_SYMBOL_VAL(sym) \ (eassert ((sym)->u.s.redirect == SYMBOL_PLAINVAL), (sym)->u.s.val.value) -#define lisp_h_SYMBOLP(x) TAGGEDP (x, Lisp_Symbol) +#define lisp_h_SYMBOL_WITH_POS_P(x) PSEUDOVECTORP ((x), PVEC_SYMBOL_WITH_POS) +#define lisp_h_BARE_SYMBOL_P(x) TAGGEDP ((x), Lisp_Symbol) +#define lisp_h_SYMBOLP(x) ((BARE_SYMBOL_P ((x)) || \ + (symbols_with_pos_enabled && (SYMBOL_WITH_POS_P ((x)))))) #define lisp_h_TAGGEDP(a, tag) \ (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ - (unsigned) (tag)) \ @@ -429,11 +452,12 @@ typedef EMACS_INT Lisp_Word; # define XLI(o) lisp_h_XLI (o) # define XIL(i) lisp_h_XIL (i) # define XLP(o) lisp_h_XLP (o) +# define BARE_SYMBOL_P(x) lisp_h_BARE_SYMBOL_P (x) # define CHECK_FIXNUM(x) lisp_h_CHECK_FIXNUM (x) # define CHECK_SYMBOL(x) lisp_h_CHECK_SYMBOL (x) # define CHECK_TYPE(ok, predicate, x) lisp_h_CHECK_TYPE (ok, predicate, x) # define CONSP(x) lisp_h_CONSP (x) -# define EQ(x, y) lisp_h_EQ (x, y) +# define BASE_EQ(x, y) lisp_h_BASE_EQ (x, y) # define FLOATP(x) lisp_h_FLOATP (x) # define FIXNUMP(x) lisp_h_FIXNUMP (x) # define NILP(x) lisp_h_NILP (x) @@ -441,7 +465,7 @@ typedef EMACS_INT Lisp_Word; # define SYMBOL_CONSTANT_P(sym) lisp_h_SYMBOL_CONSTANT_P (sym) # define SYMBOL_TRAPPED_WRITE_P(sym) lisp_h_SYMBOL_TRAPPED_WRITE_P (sym) # define SYMBOL_VAL(sym) lisp_h_SYMBOL_VAL (sym) -# define SYMBOLP(x) lisp_h_SYMBOLP (x) +/* # define SYMBOLP(x) lisp_h_SYMBOLP (x) */ /* X is accessed more than once. */ # define TAGGEDP(a, tag) lisp_h_TAGGEDP (a, tag) # define VECTORLIKEP(x) lisp_h_VECTORLIKEP (x) # define XCAR(c) lisp_h_XCAR (c) @@ -600,6 +624,7 @@ extern Lisp_Object char_table_ref (Lisp_Object, int) ATTRIBUTE_PURE; extern void char_table_set (Lisp_Object, int, Lisp_Object); /* Defined in data.c. */ +extern bool symbols_with_pos_enabled; extern AVOID args_out_of_range_3 (Lisp_Object, Lisp_Object, Lisp_Object); extern AVOID wrong_type_argument (Lisp_Object, Lisp_Object); extern Lisp_Object default_value (Lisp_Object symbol); @@ -984,57 +1009,12 @@ union vectorlike_header ptrdiff_t size; }; -INLINE bool -(SYMBOLP) (Lisp_Object x) -{ - return lisp_h_SYMBOLP (x); -} - -INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED -XSYMBOL (Lisp_Object a) -{ - eassert (SYMBOLP (a)); - intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol); - void *p = (char *) lispsym + i; - return p; -} - -INLINE Lisp_Object -make_lisp_symbol (struct Lisp_Symbol *sym) -{ - /* GCC 7 x86-64 generates faster code if lispsym is - cast to char * rather than to intptr_t. */ - char *symoffset = (char *) ((char *) sym - (char *) lispsym); - Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset); - eassert (XSYMBOL (a) == sym); - return a; -} - -INLINE Lisp_Object -builtin_lisp_symbol (int index) -{ - return make_lisp_symbol (&lispsym[index]); -} - -INLINE bool -c_symbol_p (struct Lisp_Symbol *sym) +struct Lisp_Symbol_With_Pos { - char *bp = (char *) lispsym; - char *sp = (char *) sym; - if (PTRDIFF_MAX < INTPTR_MAX) - return bp <= sp && sp < bp + sizeof lispsym; - else - { - ptrdiff_t offset = sp - bp; - return 0 <= offset && offset < sizeof lispsym; - } -} - -INLINE void -(CHECK_SYMBOL) (Lisp_Object x) -{ - lisp_h_CHECK_SYMBOL (x); -} + union vectorlike_header header; + Lisp_Object sym; /* A symbol */ + Lisp_Object pos; /* A fixnum */ +} GCALIGNED_STRUCT; /* In the size word of a vector, this bit means the vector has been marked. */ @@ -1059,6 +1039,7 @@ enum pvec_type PVEC_MARKER, PVEC_OVERLAY, PVEC_FINALIZER, + PVEC_SYMBOL_WITH_POS, PVEC_MISC_PTR, PVEC_USER_PTR, PVEC_PROCESS, @@ -1117,6 +1098,92 @@ enum More_Lisp_Bits values. They are macros for use in #if and static initializers. */ #define MOST_POSITIVE_FIXNUM (EMACS_INT_MAX >> INTTYPEBITS) #define MOST_NEGATIVE_FIXNUM (-1 - MOST_POSITIVE_FIXNUM) + +INLINE bool +PSEUDOVECTORP (Lisp_Object a, int code) +{ + return lisp_h_PSEUDOVECTORP (a, code); +} + +INLINE bool +(BARE_SYMBOL_P) (Lisp_Object x) +{ + return lisp_h_BARE_SYMBOL_P (x); +} + +INLINE bool +(SYMBOL_WITH_POS_P) (Lisp_Object x) +{ + return lisp_h_SYMBOL_WITH_POS_P (x); +} + +INLINE bool +(SYMBOLP) (Lisp_Object x) +{ + return lisp_h_SYMBOLP (x); +} + +INLINE struct Lisp_Symbol_With_Pos * +XSYMBOL_WITH_POS (Lisp_Object a) +{ + eassert (SYMBOL_WITH_POS_P (a)); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos); +} + +INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED +(XBARE_SYMBOL) (Lisp_Object a) +{ + eassert (BARE_SYMBOL_P (a)); + intptr_t i = (intptr_t) XUNTAG (a, Lisp_Symbol, struct Lisp_Symbol); + void *p = (char *) lispsym + i; + return p; +} + +INLINE struct Lisp_Symbol * ATTRIBUTE_NO_SANITIZE_UNDEFINED +(XSYMBOL) (Lisp_Object a) +{ + eassert (SYMBOLP ((a))); + if (!symbols_with_pos_enabled || BARE_SYMBOL_P (a)) + return XBARE_SYMBOL (a); + return XBARE_SYMBOL (XSYMBOL_WITH_POS (a)->sym); +} + +INLINE Lisp_Object +make_lisp_symbol (struct Lisp_Symbol *sym) +{ + /* GCC 7 x86-64 generates faster code if lispsym is + cast to char * rather than to intptr_t. */ + char *symoffset = (char *) ((char *) sym - (char *) lispsym); + Lisp_Object a = TAG_PTR (Lisp_Symbol, symoffset); + eassert (XSYMBOL (a) == sym); + return a; +} + +INLINE Lisp_Object +builtin_lisp_symbol (int index) +{ + return make_lisp_symbol (&lispsym[index]); +} + +INLINE bool +c_symbol_p (struct Lisp_Symbol *sym) +{ + char *bp = (char *) lispsym; + char *sp = (char *) sym; + if (PTRDIFF_MAX < INTPTR_MAX) + return bp <= sp && sp < bp + sizeof lispsym; + else + { + ptrdiff_t offset = sp - bp; + return 0 <= offset && offset < sizeof lispsym; + } +} + +INLINE void +(CHECK_SYMBOL) (Lisp_Object x) +{ + lisp_h_CHECK_SYMBOL (x); +} /* True if the possibly-unsigned integer I doesn't fit in a fixnum. */ @@ -1248,7 +1315,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) { @@ -1714,21 +1788,6 @@ PSEUDOVECTOR_TYPEP (const union vectorlike_header *a, enum pvec_type code) == (PSEUDOVECTOR_FLAG | (code << PSEUDOVECTOR_AREA_BITS))); } -/* True if A is a pseudovector whose code is CODE. */ -INLINE bool -PSEUDOVECTORP (Lisp_Object a, int code) -{ - if (! VECTORLIKEP (a)) - return false; - else - { - /* Converting to union vectorlike_header * avoids aliasing issues. */ - return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike, - union vectorlike_header), - code); - } -} - /* A boolvector is a kind of vectorlike, with contents like a string. */ struct Lisp_Bool_Vector @@ -2627,6 +2686,22 @@ XOVERLAY (Lisp_Object a) return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Overlay); } +INLINE Lisp_Object +SYMBOL_WITH_POS_SYM (Lisp_Object a) +{ + if (!SYMBOL_WITH_POS_P (a)) + wrong_type_argument (Qsymbol_with_pos_p, a); + return XSYMBOL_WITH_POS (a)->sym; +} + +INLINE Lisp_Object +SYMBOL_WITH_POS_POS (Lisp_Object a) +{ + if (!SYMBOL_WITH_POS_P (a)) + wrong_type_argument (Qsymbol_with_pos_p, a); + return XSYMBOL_WITH_POS (a)->pos; +} + INLINE bool USER_PTRP (Lisp_Object x) { @@ -4030,6 +4105,7 @@ extern bool gc_in_progress; extern Lisp_Object make_float (double); extern void display_malloc_warning (void); extern ptrdiff_t inhibit_garbage_collection (void); +extern Lisp_Object build_symbol_with_pos (Lisp_Object, Lisp_Object); extern Lisp_Object build_overlay (Lisp_Object, Lisp_Object, Lisp_Object); extern void free_cons (struct Lisp_Cons *); extern void init_alloc_once (void); diff --git a/src/lread.c b/src/lread.c index 2e63ec48912..7775911c1d3 100644 --- a/src/lread.c +++ b/src/lread.c @@ -647,12 +647,12 @@ struct subst }; static Lisp_Object read_internal_start (Lisp_Object, Lisp_Object, - Lisp_Object); -static Lisp_Object read0 (Lisp_Object); -static Lisp_Object read1 (Lisp_Object, int *, bool); + Lisp_Object, bool); +static Lisp_Object read0 (Lisp_Object, bool); +static Lisp_Object read1 (Lisp_Object, int *, bool, bool); -static Lisp_Object read_list (bool, Lisp_Object); -static Lisp_Object read_vector (Lisp_Object, bool); +static Lisp_Object read_list (bool, Lisp_Object, bool); +static Lisp_Object read_vector (Lisp_Object, bool, bool); static Lisp_Object substitute_object_recurse (struct subst *, Lisp_Object); static void substitute_in_interval (INTERVAL, void *); @@ -2280,7 +2280,7 @@ readevalloop (Lisp_Object readcharfun, Qnil, false); if (!NILP (Vpurify_flag) && c == '(') { - val = read_list (0, readcharfun); + val = read_list (0, readcharfun, false); } else { @@ -2302,7 +2302,7 @@ readevalloop (Lisp_Object readcharfun, else if (! NILP (Vload_read_function)) val = call1 (Vload_read_function, readcharfun); else - val = read_internal_start (readcharfun, Qnil, Qnil); + val = read_internal_start (readcharfun, Qnil, Qnil, false); } /* Empty hashes can be reused; otherwise, reset on next call. */ if (HASH_TABLE_P (read_objects_map) @@ -2460,7 +2460,35 @@ STREAM or the value of `standard-input' may be: return call1 (intern ("read-minibuffer"), build_string ("Lisp expression: ")); - return read_internal_start (stream, Qnil, Qnil); + return read_internal_start (stream, Qnil, Qnil, false); +} + +DEFUN ("read-positioning-symbols", Fread_positioning_symbols, + Sread_positioning_symbols, 0, 1, 0, + doc: /* Read one Lisp expression as text from STREAM, return as Lisp object. +Convert each occurrence of a symbol into a "symbol with pos" object. + +If STREAM is nil, use the value of `standard-input' (which see). +STREAM or the value of `standard-input' may be: + a buffer (read from point and advance it) + a marker (read from where it points and advance it) + a function (call it with no arguments for each character, + call it with a char as argument to push a char back) + a string (takes text from string, starting at the beginning) + t (read text line using minibuffer and use it, or read from + standard input in batch mode). */) + (Lisp_Object stream) +{ + if (NILP (stream)) + stream = Vstandard_input; + if (EQ (stream, Qt)) + stream = Qread_char; + if (EQ (stream, Qread_char)) + /* FIXME: ?! When is this used !? */ + return call1 (intern ("read-minibuffer"), + build_string ("Lisp expression: ")); + + return read_internal_start (stream, Qnil, Qnil, true); } DEFUN ("read-from-string", Fread_from_string, Sread_from_string, 1, 3, 0, @@ -2476,14 +2504,17 @@ the end of STRING. */) Lisp_Object ret; CHECK_STRING (string); /* `read_internal_start' sets `read_from_string_index'. */ - ret = read_internal_start (string, start, end); + ret = read_internal_start (string, start, end, false); return Fcons (ret, make_fixnum (read_from_string_index)); } /* Function to set up the global context we need in toplevel read - calls. START and END only used when STREAM is a string. */ + calls. START and END only used when STREAM is a string. + LOCATE_SYMS true means read symbol occurrences as symbols with + position. */ static Lisp_Object -read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end) +read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end, + bool locate_syms) { Lisp_Object retval; @@ -2523,7 +2554,7 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end) read_from_string_limit = endval; } - retval = read0 (stream); + retval = read0 (stream, locate_syms); if (EQ (Vread_with_symbol_positions, Qt) || EQ (Vread_with_symbol_positions, stream)) Vread_symbol_positions_list = Fnreverse (Vread_symbol_positions_list); @@ -2542,12 +2573,12 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end) are not allowed. */ static Lisp_Object -read0 (Lisp_Object readcharfun) +read0 (Lisp_Object readcharfun, bool locate_syms) { register Lisp_Object val; int c; - val = read1 (readcharfun, &c, 0); + val = read1 (readcharfun, &c, 0, locate_syms); if (!c) return val; @@ -2971,10 +3002,12 @@ read_integer (Lisp_Object readcharfun, int radix, in *PCH and the return value is not interesting. Else, we store zero in *PCH and we read and return one lisp object. - FIRST_IN_LIST is true if this is the first element of a list. */ + FIRST_IN_LIST is true if this is the first element of a list. + LOCATE_SYMS true means read symbol occurrences as symbols with + position. */ static Lisp_Object -read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) +read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms) { int c; bool uninterned_symbol = false; @@ -2994,10 +3027,10 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) switch (c) { case '(': - return read_list (0, readcharfun); + return read_list (0, readcharfun, locate_syms); case '[': - return read_vector (readcharfun, 0); + return read_vector (readcharfun, 0, locate_syms); case ')': case ']': @@ -3016,7 +3049,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) /* Accept extended format for hash tables (extensible to other types), e.g. #s(hash-table size 2 test equal data (k1 v1 k2 v2)) */ - Lisp_Object tmp = read_list (0, readcharfun); + Lisp_Object tmp = read_list (0, readcharfun, false); Lisp_Object head = CAR_SAFE (tmp); Lisp_Object data = Qnil; Lisp_Object val = Qnil; @@ -3105,7 +3138,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (c == '[') { Lisp_Object tmp; - tmp = read_vector (readcharfun, 0); + tmp = read_vector (readcharfun, 0, false); if (ASIZE (tmp) < CHAR_TABLE_STANDARD_SLOTS) error ("Invalid size char-table"); XSETPVECTYPE (XVECTOR (tmp), PVEC_CHAR_TABLE); @@ -3118,7 +3151,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) { /* Sub char-table can't be read as a regular vector because of a two C integer fields. */ - Lisp_Object tbl, tmp = read_list (1, readcharfun); + Lisp_Object tbl, tmp = read_list (1, readcharfun, false); ptrdiff_t size = list_length (tmp); int i, depth, min_char; struct Lisp_Cons *cell; @@ -3156,7 +3189,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (c == '&') { Lisp_Object length; - length = read1 (readcharfun, pch, first_in_list); + length = read1 (readcharfun, pch, first_in_list, false); c = READCHAR; if (c == '"') { @@ -3165,7 +3198,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) unsigned char *data; UNREAD (c); - tmp = read1 (readcharfun, pch, first_in_list); + tmp = read1 (readcharfun, pch, first_in_list, false); if (STRING_MULTIBYTE (tmp) || (size_in_chars != SCHARS (tmp) /* We used to print 1 char too many @@ -3193,7 +3226,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) build them using function calls. */ Lisp_Object tmp; struct Lisp_Vector *vec; - tmp = read_vector (readcharfun, 1); + tmp = read_vector (readcharfun, 1, locate_syms); vec = XVECTOR (tmp); if (! (COMPILED_STACK_DEPTH < ASIZE (tmp) && (FIXNUMP (AREF (tmp, COMPILED_ARGLIST)) @@ -3243,7 +3276,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) int ch; /* Read the string itself. */ - tmp = read1 (readcharfun, &ch, 0); + tmp = read1 (readcharfun, &ch, 0, false); if (ch != 0 || !STRINGP (tmp)) invalid_syntax ("#", readcharfun); /* Read the intervals and their properties. */ @@ -3251,14 +3284,14 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) { Lisp_Object beg, end, plist; - beg = read1 (readcharfun, &ch, 0); + beg = read1 (readcharfun, &ch, 0, false); end = plist = Qnil; if (ch == ')') break; if (ch == 0) - end = read1 (readcharfun, &ch, 0); + end = read1 (readcharfun, &ch, 0, false); if (ch == 0) - plist = read1 (readcharfun, &ch, 0); + plist = read1 (readcharfun, &ch, 0, false); if (ch) invalid_syntax ("Invalid string property list", readcharfun); Fset_text_properties (beg, end, plist, tmp); @@ -3369,7 +3402,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (c == '$') return Vload_file_name; if (c == '\'') - return list2 (Qfunction, read0 (readcharfun)); + return list2 (Qfunction, read0 (readcharfun, locate_syms)); /* #:foo is the uninterned symbol named foo. */ if (c == ':') { @@ -3452,7 +3485,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) hash_put (h, number, placeholder, hash); /* Read the object itself. */ - Lisp_Object tem = read0 (readcharfun); + Lisp_Object tem = read0 (readcharfun, locate_syms); /* If it can be recursive, remember it for future substitutions. */ @@ -3508,6 +3541,9 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) else if (c == 'b' || c == 'B') return read_integer (readcharfun, 2, stackbuf); + char acm_buf[15]; /* FIXME!!! 2021-11-27. */ + sprintf (acm_buf, "#%c", c); + invalid_syntax (acm_buf, readcharfun); UNREAD (c); invalid_syntax ("#", readcharfun); @@ -3516,10 +3552,10 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) goto retry; case '\'': - return list2 (Qquote, read0 (readcharfun)); + return list2 (Qquote, read0 (readcharfun, locate_syms)); case '`': - return list2 (Qbackquote, read0 (readcharfun)); + return list2 (Qbackquote, read0 (readcharfun, locate_syms)); case ',': { @@ -3535,7 +3571,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) comma_type = Qcomma; } - value = read0 (readcharfun); + value = read0 (readcharfun, locate_syms); return list2 (comma_type, value); } case '?': @@ -3842,6 +3878,11 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) result = intern_driver (name, obarray, tem); } } + if (locate_syms + && !NILP (result) + ) + result = build_symbol_with_pos (result, + make_fixnum (start_position)); if (EQ (Vread_with_symbol_positions, Qt) || EQ (Vread_with_symbol_positions, readcharfun)) @@ -4100,9 +4141,9 @@ string_to_number (char const *string, int base, ptrdiff_t *plen) static Lisp_Object -read_vector (Lisp_Object readcharfun, bool bytecodeflag) +read_vector (Lisp_Object readcharfun, bool bytecodeflag, bool locate_syms) { - Lisp_Object tem = read_list (1, readcharfun); + Lisp_Object tem = read_list (1, readcharfun, locate_syms); ptrdiff_t size = list_length (tem); Lisp_Object vector = make_nil_vector (size); @@ -4174,10 +4215,12 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag) return vector; } -/* FLAG means check for ']' to terminate rather than ')' and '.'. */ +/* FLAG means check for ']' to terminate rather than ')' and '.'. + LOCATE_SYMS true means read symbol occurrencess as symbols with + position. */ static Lisp_Object -read_list (bool flag, Lisp_Object readcharfun) +read_list (bool flag, Lisp_Object readcharfun, bool locate_syms) { Lisp_Object val, tail; Lisp_Object elt, tem; @@ -4195,7 +4238,7 @@ read_list (bool flag, Lisp_Object readcharfun) while (1) { int ch; - elt = read1 (readcharfun, &ch, first_in_list); + elt = read1 (readcharfun, &ch, first_in_list, locate_syms); first_in_list = 0; @@ -4239,10 +4282,10 @@ read_list (bool flag, Lisp_Object readcharfun) if (ch == '.') { if (!NILP (tail)) - XSETCDR (tail, read0 (readcharfun)); + XSETCDR (tail, read0 (readcharfun, locate_syms)); else - val = read0 (readcharfun); - read1 (readcharfun, &ch, 0); + val = read0 (readcharfun, locate_syms); + read1 (readcharfun, &ch, 0, locate_syms); if (ch == ')') { @@ -5120,6 +5163,7 @@ void syms_of_lread (void) { defsubr (&Sread); + defsubr (&Sread_positioning_symbols); defsubr (&Sread_from_string); defsubr (&Slread__substitute_object_in_subtree); defsubr (&Sintern); diff --git a/src/print.c b/src/print.c index adadb289de0..eb0fe591b85 100644 --- a/src/print.c +++ b/src/print.c @@ -1416,6 +1416,30 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, printchar ('>', printcharfun); break; + case PVEC_SYMBOL_WITH_POS: + { + struct Lisp_Symbol_With_Pos *sp = XSYMBOL_WITH_POS (obj); + if (print_symbols_bare) + print_object (sp->sym, printcharfun, escapeflag); + else + { + print_c_string ("#sym)) + print_object (sp->sym, printcharfun, escapeflag); + else + print_c_string ("NOT A SYMBOL!!", printcharfun); + if (FIXNUMP (sp->pos)) + { + print_c_string (" at ", printcharfun); + print_object (sp->pos, printcharfun, escapeflag); + } + else + print_c_string (" NOT A POSITION!!", printcharfun); + printchar ('>', printcharfun); + } + } + break; + case PVEC_OVERLAY: print_c_string ("#buffer) @@ -1921,7 +1945,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) error ("Apparently circular structure being printed"); for (i = 0; i < print_depth; i++) - if (EQ (obj, being_printed[i])) + if (BASE_EQ (obj, being_printed[i])) { int len = sprintf (buf, "#%d", i); strout (buf, len, len, printcharfun); @@ -2425,6 +2449,13 @@ priorities. Values other than nil or t are also treated as `default'. */); Vprint_charset_text_property = Qdefault; + DEFVAR_BOOL ("print-symbols-bare", print_symbols_bare, + doc: /* A flag to control printing of symbols with position. +If the value is nil, print these objects complete with position. +Otherwise print just the bare symbol. */); + print_symbols_bare = false; + DEFSYM (Qprint_symbols_bare, "print-symbols-bare"); + /* prin1_to_string_buffer initialized in init_buffer_once in buffer.c */ staticpro (&Vprin1_to_string_buffer); -- 2.39.5