From 368570b3fd09d03ac5b9276d1ca85ae813c3f385 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Mon, 29 Nov 2021 11:19:31 +0000 Subject: 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 + 10 files changed, 411 insertions(+), 187 deletions(-) (limited to 'lisp/emacs-lisp') 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) -- cgit v1.2.3 From 8f1106ddf2a3861e9c1ebb9d8fa3d4087899de81 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Wed, 1 Dec 2021 20:03:44 +0000 Subject: Several amendments to scratch/correct-warning-pos. The position return by read-positioning-symbols is now the position in the buffer, rather than the offset from the start of a form, enabling warning positions in other parts of the buffer to be output. * src/lisp.h (lisp_h_EQ): Add XLI casts so that it compiles cleanly. * src/data.c (Fremove_pos_from_symbol): New DEFUN. * src/lread.c (readchar_count): renamed to readchar_offset. (read_internal_start) Initialize readchar_offset to the buffer's point when STREAM is a buffer. * lisp/emacs-lisp/bytecomp.el (byte-compile-warning-prefix): Amend to use OFFSET as a buffer position, not an offset from the start of a form. (byte-compile-warn): Remove symbol positions from any shape of ARGS, not just a symbol with position. * lisp/emacs-lisp/cconv.c (cconv-convert): In the :unused case, position the new IGNORE symbol with the VAR it has replaced. * lisp/emacs-lisp/macroexp.el (macroexp--warn-wrap, macroexp-warn-and-return): Add an extra position parameter to each. * lisp/emacs-lisp/bindat.el (bindat-type), lisp/emacs-lisp/byte-run.el (defmacro, defun), lisp/emacs-lisp/cconv.el (cconv--convert-func-body) (cconv-convert), lisp/emacs-lisp/cl-generic.el (cl-defmethod), lisp/emacs-lisp/cl-macs.el (cl-symbol-macrolet, cl-defstruct), lisp/emacs-lisp/easy-mmode.el (define-minor-mode), lisp/emacs-lisp/eieio-core.el (eieio-oref, eieio-oref-default) (eieio-oset-default), lisp/emacs-lisp/eieio.el (defclass), lisp/emacs-lisp/gv.el (gv-ref), lisp/emacs-lisp/macroexp.el (macroexp-macroexpand, macroexp--unfold-lambda, macroexp--expand-all), lisp/emacs-lisp/pcase.el (pcase-compile-patterns, pcase--u1): Add an extra position argument to each call of macroexp-warn-and-return. --- lisp/emacs-lisp/bindat.el | 1 + lisp/emacs-lisp/byte-run.el | 4 +++- lisp/emacs-lisp/bytecomp.el | 9 ++------- lisp/emacs-lisp/cconv.el | 19 +++++++++++-------- lisp/emacs-lisp/cl-generic.el | 2 +- lisp/emacs-lisp/cl-macs.el | 6 +++--- lisp/emacs-lisp/easy-mmode.el | 1 + lisp/emacs-lisp/eieio-core.el | 6 +++++- lisp/emacs-lisp/eieio.el | 5 +++-- lisp/emacs-lisp/gv.el | 2 +- lisp/emacs-lisp/macroexp.el | 16 ++++++++-------- lisp/emacs-lisp/pcase.el | 3 ++- src/data.c | 16 ++++++++++++++-- src/lisp.h | 10 +++++----- src/lread.c | 13 ++++++------- 15 files changed, 66 insertions(+), 47 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 76c2e80fda8..17a55c7dbaa 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -804,6 +804,7 @@ is the name of a variable that will hold the value we need to pack.") (if (or (eq label '_) (not (assq label labels))) code (macroexp-warn-and-return + code (format "Duplicate label: %S" label) code)))) (`(,_ ,val) diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index d82d9454e84..813ff53ea73 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -253,7 +253,8 @@ The return value is undefined. #'(lambda (x) (let ((f (cdr (assq (car x) macro-declarations-alist)))) (if f (apply (car f) name arglist (cdr x)) - (macroexp-warn-and-return + (macroexp-warn-and-return + (car x) (format-message "Unknown macro property %S in %S" (car x) name) @@ -327,6 +328,7 @@ The return value is undefined. nil) (t (macroexp-warn-and-return + (car x) (format-message "Unknown defun property `%S' in %S" (car x) name) nil))))) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 869b6c01b8a..2f23fe743ec 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1326,7 +1326,7 @@ Return nil if such is not found." (goto-char byte-compile-last-position) (setq old-l (1+ (count-lines (point-min) (point-at-bol))) old-c (1+ (current-column))) - (goto-char (+ byte-compile-read-position offset)) + (goto-char offset) (setq new-l (1+ (count-lines (point-min) (point-at-bol))) new-c (1+ (current-column))) (format "%d:%d:%d:%d:" old-l old-c new-l new-c))) @@ -1435,12 +1435,7 @@ function directly; use `byte-compile-warn' or (defun byte-compile-warn (format &rest args) "Issue a byte compiler warning; use (format-message FORMAT ARGS...) for message." - (setq args - (mapcar (lambda (arg) - (if (symbolp arg) - (bare-symbol arg) - arg)) - args)) + (setq args (mapcar #'byte-compile-strip-symbol-positions args)) (setq format (apply #'format-message format args)) (if byte-compile-error-on-warn (error "%s" format) ; byte-compile-file catches and logs it diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 9c9ebe15d5d..e12f0a1753b 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -258,11 +258,11 @@ Returns a form where all lambdas don't have any free variables." ;; unused vars. (not (intern-soft var)) (eq ?_ (aref (symbol-name var) 0)) - ;; As a special exception, ignore "ignore". + ;; As a special exception, ignore "ignored". (eq var 'ignored)) (let ((suggestions (help-uni-confusable-suggestions (symbol-name var)))) (format "Unused lexical %s `%S'%s" - varkind var + varkind (bare-symbol var) (if suggestions (concat "\n " suggestions) ""))))) (define-inline cconv--var-classification (binder form) @@ -286,7 +286,7 @@ of converted forms." (let (and (pred stringp) msg) (cconv--warn-unused-msg arg "argument"))) (if (assq arg env) (push `(,arg . nil) env)) ;FIXME: Is it needed? - (push (lambda (body) (macroexp--warn-wrap msg body 'lexical)) wrappers)) + (push (lambda (body) (macroexp--warn-wrap body msg body 'lexical)) wrappers)) (_ (if (assq arg env) (push `(,arg . nil) env))))) (setq funcbody (mapcar (lambda (form) @@ -414,11 +414,14 @@ places where they originally did not directly appear." ;; Declared variable is unused. (if (assq var new-env) (push `(,var) new-env)) ;FIXME:Needed? - (let ((newval - `(ignore ,(cconv-convert value env extend))) - (msg (cconv--warn-unused-msg var "variable"))) + (let* ((Ignore (if (symbol-with-pos-p var) + (position-symbol 'ignore var) + 'ignore)) + (newval `(,Ignore + ,(cconv-convert value env extend))) + (msg (cconv--warn-unused-msg var "variable"))) (if (null msg) newval - (macroexp--warn-wrap msg newval 'lexical)))) + (macroexp--warn-wrap var msg newval 'lexical)))) ;; Normal default case. (_ @@ -517,7 +520,7 @@ places where they originally did not directly appear." (newprotform (cconv-convert protected-form env extend))) `(condition-case ,var ,(if msg - (macroexp--warn-wrap msg newprotform 'lexical) + (macroexp--warn-wrap var msg newprotform 'lexical) newprotform) ,@(mapcar (lambda (handler) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index b94737e0fee..43214aab30c 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -512,7 +512,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (byte-compile-warning-enabled-p 'obsolete name)) (let* ((obsolete (get name 'byte-obsolete-info))) (macroexp-warn-and-return - ;; org-name + org-name (macroexp--obsolete-warning name obsolete "generic function") nil))) ;; You could argue that `defmethod' modifies rather than defines the diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index dbe0eb1b0e2..3659a0c95a2 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2449,7 +2449,7 @@ by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...). (if malformed-bindings (let ((rev-malformed-bindings (nreverse malformed-bindings))) (macroexp-warn-and-return - ;; rev-malformed-bindings + rev-malformed-bindings (format-message "Malformed `cl-symbol-macrolet' binding(s): %S" rev-malformed-bindings) expansion)) @@ -3136,7 +3136,7 @@ To see the documentation for a defined struct type, use (when (cl-oddp (length desc)) (push (macroexp-warn-and-return - ;; (car (last desc)) + (car (last desc)) (format "Missing value for option `%S' of slot `%s' in struct %s!" (car (last desc)) slot name) 'nil) @@ -3146,7 +3146,7 @@ To see the documentation for a defined struct type, use (let ((kw (car defaults))) (push (macroexp-warn-and-return - ;; kw + kw (format " I'll take `%s' to be an option rather than a default value." kw) 'nil) diff --git a/lisp/emacs-lisp/easy-mmode.el b/lisp/emacs-lisp/easy-mmode.el index db86e0e0292..59038f6e9b2 100644 --- a/lisp/emacs-lisp/easy-mmode.el +++ b/lisp/emacs-lisp/easy-mmode.el @@ -230,6 +230,7 @@ INIT-VALUE LIGHTER KEYMAP. (warnwrap (if (or (null body) (keywordp (car body))) #'identity (lambda (exp) (macroexp-warn-and-return + exp "Use keywords rather than deprecated positional arguments to `define-minor-mode'" exp)))) keyw keymap-sym tmp) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 4e9357c2ada..b17ecd34d4d 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -744,7 +744,7 @@ Argument FN is the function calling this verifier." ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return - ;; name + name (format-message "Unknown slot `%S'" name) exp nil 'compile-only)) (_ exp)))) @@ -781,11 +781,13 @@ Fills in CLASS's SLOT with its default value." ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return + name (format-message "Unknown slot `%S'" name) exp nil 'compile-only)) ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-class-slot-names)))) (macroexp-warn-and-return + name (format-message "Slot `%S' is not class-allocated" name) exp nil 'compile-only)) (_ exp))))) @@ -843,11 +845,13 @@ Fills in the default value in CLASS' in SLOT with VALUE." ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-slot-names)))) (macroexp-warn-and-return + name (format-message "Unknown slot `%S'" name) exp nil 'compile-only)) ((and (or `',name (and name (pred keywordp))) (guard (not (memq name eieio--known-class-slot-names)))) (macroexp-warn-and-return + name (format-message "Slot `%S' is not class-allocated" name) exp nil 'compile-only)) (_ exp))))) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 76f7b661a62..0d0dff6d68e 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -242,7 +242,8 @@ This method is obsolete." `(progn ,@(mapcar (lambda (w) - (macroexp-warn-and-return w `(progn ',w) nil 'compile-only)) + (macroexp-warn-and-return w ; W is probably a poor choice for a position. + w `(progn ',w) nil 'compile-only)) warnings) ;; This test must be created right away so we can have self- ;; referencing classes. ei, a class whose slot can contain only @@ -292,7 +293,7 @@ This method is obsolete." (if (not (stringp (car slots))) whole (macroexp-warn-and-return - ;; (car slots) + (car slots) (format "Obsolete name arg %S to constructor %S" (car slots) (car whole)) ;; Keep the name arg, for backward compatibility, diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index ed33524f2dc..eb65e5f1046 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -595,7 +595,7 @@ binding mode." (eq (car-safe code) 'cons)) code (macroexp-warn-and-return - ;; org-place + org-place "Use of gv-ref probably requires lexical-binding" code)))) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 6d114a8a547..60fac981308 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -135,18 +135,17 @@ Other uses risk returning non-nil value that point to the wrong file." (defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key)) -(defun macroexp--warn-wrap (msg form category) +(defun macroexp--warn-wrap (arg msg form category) (let ((when-compiled (lambda () (when (byte-compile-warning-enabled-p category) - (byte-compile-warn-x form "%s" msg))))) + (byte-compile-warn-x arg "%s" msg))))) `(progn (macroexp--funcall-if-compiled ',when-compiled) ,form))) (define-obsolete-function-alias 'macroexp--warn-and-return #'macroexp-warn-and-return "28.1") -(defun macroexp-warn-and-return (;; _arg - msg form &optional category compile-only) +(defun macroexp-warn-and-return (arg msg form &optional category compile-only) "Return code equivalent to FORM labeled with warning MSG. CATEGORY is the category of the warning, like the categories that can appear in `byte-compile-warnings'. @@ -161,7 +160,7 @@ is executed without being compiled first." ;; macroexpand-all gets right back to macroexpanding `form'. form (puthash form form macroexp--warned) - (macroexp--warn-wrap msg form category))) + (macroexp--warn-wrap arg msg form category))) (t (unless compile-only (message "%sWarning: %s" @@ -217,7 +216,7 @@ is executed without being compiled first." (let* ((fun (car form)) (obsolete (get fun 'byte-obsolete-info))) (macroexp-warn-and-return - ;; fun + fun (macroexp--obsolete-warning fun obsolete (if (symbolp (symbol-function fun)) @@ -273,6 +272,7 @@ is executed without being compiled first." (setq arglist (cdr arglist))) (if values (macroexp-warn-and-return + name (format (if (eq values 'too-few) "attempt to open-code `%s' with too few arguments" "attempt to open-code `%s' with too many arguments") @@ -332,7 +332,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (if (null body) (macroexp-unprogn (macroexp-warn-and-return - ;; fun + fun (format "Empty %s body" fun) nil nil 'compile-only)) (macroexp--all-forms body)) @@ -370,7 +370,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (eq 'lambda (car-safe (cadr arg)))) (setcar (nthcdr funarg form) (macroexp-warn-and-return - ;; (nth 1 f) + (cadr arg) (format "%S quoted with ' rather than with #'" (let ((f (cadr arg))) (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 430ae97078c..81280d4e041 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -433,6 +433,7 @@ how many time this CODEGEN is called." (memq (car case) pcase--dontwarn-upats)) (setq main (macroexp-warn-and-return + (car case) (format "pcase pattern %S shadowed by previous pcase pattern" (car case)) main)))) @@ -940,7 +941,7 @@ Otherwise, it defers to REST which is a list of branches of the form (let ((code (pcase--u1 matches code vars rest))) (if (eq upat '_) code (macroexp-warn-and-return - ;; upat + upat "Pattern t is deprecated. Use `_' instead" code)))) ((eq upat 'pcase--dontcare) :pcase--dontcare) diff --git a/src/data.c b/src/data.c index b3b157a7f39..1f2af6f4743 100644 --- a/src/data.c +++ b/src/data.c @@ -776,7 +776,7 @@ DEFUN ("symbol-name", Fsymbol_name, Ssymbol_name, 1, 1, 0, DEFUN ("bare-symbol", Fbare_symbol, Sbare_symbol, 1, 1, 0, doc: /* Extract, if need be, the bare symbol from SYM, a symbol. */) - (register Lisp_Object sym) + (register Lisp_Object sym) { if (BARE_SYMBOL_P (sym)) return sym; @@ -786,12 +786,23 @@ DEFUN ("bare-symbol", Fbare_symbol, Sbare_symbol, 1, 1, 0, DEFUN ("symbol-with-pos-pos", Fsymbol_with_pos_pos, Ssymbol_with_pos_pos, 1, 1, 0, doc: /* Extract the position from a symbol with position. */) - (register Lisp_Object ls) + (register Lisp_Object ls) { /* Type checking is done in the following macro. */ return SYMBOL_WITH_POS_POS (ls); } +DEFUN ("remove-pos-from-symbol", Fremove_pos_from_symbol, + Sremove_pos_from_symbol, 1, 1, 0, + doc: /* If ARG is a symbol with position, return it without the position. +Otherwise, return ARG unchanged. Compare with `bare-symbol'. */) + (register Lisp_Object arg) +{ + if (SYMBOL_WITH_POS_P (arg)) + return (SYMBOL_WITH_POS_SYM (arg)); + return arg; +} + DEFUN ("position-symbol", Fposition_symbol, Sposition_symbol, 2, 2, 0, doc: /* Create a new symbol with position. SYM is a symbol, with or without position, the symbol to position. @@ -4193,6 +4204,7 @@ syms_of_data (void) defsubr (&Ssymbol_name); defsubr (&Sbare_symbol); defsubr (&Ssymbol_with_pos_pos); + defsubr (&Sremove_pos_from_symbol); defsubr (&Sposition_symbol); defsubr (&Smakunbound); defsubr (&Sfmakunbound); diff --git a/src/lisp.h b/src/lisp.h index 08013e94d16..00d9843d6a3 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -366,7 +366,7 @@ typedef EMACS_INT Lisp_Word; #define lisp_h_PSEUDOVECTORP(a,code) \ (lisp_h_VECTORLIKEP((a)) && \ - ((XUNTAG ((a), Lisp_Vectorlike, union vectorlike_header)->size \ + ((XUNTAG ((a), Lisp_Vectorlike, union vectorlike_header)->size \ & (PSEUDOVECTOR_FLAG | PVEC_TYPE_MASK)) \ == (PSEUDOVECTOR_FLAG | ((code) << PSEUDOVECTOR_AREA_BITS)))) @@ -382,13 +382,13 @@ typedef EMACS_INT Lisp_Word; || (symbols_with_pos_enabled \ && (SYMBOL_WITH_POS_P ((x)) \ ? BARE_SYMBOL_P ((y)) \ - ? (XSYMBOL_WITH_POS((x)))->sym == (y) \ + ? XLI (XSYMBOL_WITH_POS((x))->sym) == XLI (y) \ : SYMBOL_WITH_POS_P((y)) \ - && ((XSYMBOL_WITH_POS((x)))->sym \ - == (XSYMBOL_WITH_POS((y)))->sym) \ + && (XLI (XSYMBOL_WITH_POS((x))->sym) \ + == XLI (XSYMBOL_WITH_POS((y))->sym)) \ : (SYMBOL_WITH_POS_P ((y)) \ && BARE_SYMBOL_P ((x)) \ - && ((x) == ((XSYMBOL_WITH_POS ((y)))->sym)))))) + && (XLI (x) == XLI ((XSYMBOL_WITH_POS ((y)))->sym)))))) #define lisp_h_FIXNUMP(x) \ (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) \ diff --git a/src/lread.c b/src/lread.c index 7775911c1d3..1cc5acc6d3a 100644 --- a/src/lread.c +++ b/src/lread.c @@ -128,9 +128,8 @@ static ptrdiff_t read_from_string_index; static ptrdiff_t read_from_string_index_byte; static ptrdiff_t read_from_string_limit; -/* Number of characters read in the current call to Fread or - Fread_from_string. */ -static EMACS_INT readchar_count; +/* Position in object from which characters are being read by `readchar'. */ +static EMACS_INT readchar_offset; /* This contains the last string skipped with #@. */ static char *saved_doc_string; @@ -213,7 +212,7 @@ readchar (Lisp_Object readcharfun, bool *multibyte) if (multibyte) *multibyte = 0; - readchar_count++; + readchar_offset++; if (BUFFERP (readcharfun)) { @@ -424,7 +423,7 @@ skip_dyn_eof (Lisp_Object readcharfun) static void unreadchar (Lisp_Object readcharfun, int c) { - readchar_count--; + readchar_offset--; if (c == -1) /* Don't back up the pointer if we're unreading the end-of-input mark, since readchar didn't advance it when we read it. */ @@ -2518,7 +2517,7 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end, { Lisp_Object retval; - readchar_count = 0; + readchar_offset = BUFFERP (stream) ? XBUFFER (stream)->pt : 0; /* We can get called from readevalloop which may have set these already. */ if (! HASH_TABLE_P (read_objects_map) @@ -3773,7 +3772,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms) char *p = read_buffer; char *end = read_buffer + read_buffer_size; bool quoted = false; - EMACS_INT start_position = readchar_count - 1; + EMACS_INT start_position = readchar_offset - 1; do { -- cgit v1.2.3 From 1cd188799f86bcb13ad76e82e3436b1b7e9f9e9f Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Thu, 30 Dec 2021 10:14:58 +0000 Subject: Make symbols with positions work with native compilation This version of the software should bootstrap Emacs successfully with native compilation enabled. * lisp/emacs-lisp/bytecomp.el (byte-compile-strip-s-p-1) (byte-compile-strip-symbol-positions): Rename and move to macroexp.el. Rename calls to these functions throughout the file. (byte-compile-initial-macro-environment): In the code sections for eval-when-compile and eval-and-compile, call macroexp-strip-symbol-positions before evaluating code. (byte-compile-file, byte-compile-output-file-form) (byte-compile-file-form-defmumble, byte-compile, batch-byte-compile): Call macroexp-strip-symbol-positions from code being passed to the native compiler. * lisp/emacs-lisp/cl-macs.el (cl-macs--strip-s-p-1) (cl-macs--strip-symbol-positions): Remove, replacing them with the renamed functions in macroexp.el. (cl-define-compiler-macro): Apply macroexp-strip-symbol-positions to ARGS and BODY. * lisp/emacs-lisp/comp.el (comp-limplify-lap-inst): Use `null' to compile byte-not rather than a compilation of `eq'. (comp--native-compile): bind symbols-with-pos-enabled to t. * lisp/emacs-lisp/macroexp.el (byte-compile--ssp-conses-seen) (byte-compile--ssp-vectors-seen, byte-compile--ssp-records-seen): Provisional auxiliary variables to support the following functions. (macroexp--strip-s-p-2, byte-compile-strip-s-p-1) (macroexp-strip-symbol-positions): Functions moved from bytecomp.el, renamed, and further developed. (macroexp--compiler-macro): Bind symbol-with-pos-enabled to t around the call to `handler'. (internal-macroexpand-for-load): Strip symbol positions from the form being eagerly expanded for macros. * src/comp.c (F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM): New macro for a relocation symbol. (comp_t): New elements bool_ptr_type, f_symbols_with_pos_enabled_ref, lisp_symbol_with_position, lisp_symbol_with_position_header, lisp_symbol_with_position_sym, lisp_symbol_with_position_pos, lisp_symbol_with_position_type, lisp_symbol_with_position_ptr_type, get_symbol_with_position. (helper_GET_SYMBOL_WITH_POSITION): New function. (emit_BASE_EQ): Function rename from emit_EQ. (emit_AND, emit_OR, emit_BARE_SYMBOL_P, emit_SYMBOL_WITH_POS_P) (emit_SYMBOL_WITH_POS_SYM): New functions. (emit_EQ): New function which handles symbols with position correctly. (emit_NILP): Use emit_BASE_EQ rather than emit_EQ. (emit_limple_insn): When emitting a conditional branch, check each operand for being a literal Qnil, and if one of them is, use emit_BASE_EQ rather than emit_EQ. (declare_runtime_imported_funcs): Declare helper_GET_SYMBOL_WITH_POSITION. (emit_ctxt_code): Export the global F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM. (define_lisp_symbol_with_position, define_GET_SYMBOL_WITH_POSITION): New functions. (Fcomp__init_ctxt): Initialise comp.bool_ptr_type, call the two new define_.... functions. (load_comp_unit): Initialise **f_symbols_with_pos_enabled_reloc. * src/fns.c (Fput): Strip positions from symbols in PROPNAME and VALUE. --- lisp/emacs-lisp/bytecomp.el | 507 +++++++++++++++++++++----------------------- lisp/emacs-lisp/cl-macs.el | 35 +-- lisp/emacs-lisp/comp.el | 13 +- lisp/emacs-lisp/macroexp.el | 66 +++++- src/comp.c | 242 ++++++++++++++++++++- src/fns.c | 5 + 6 files changed, 561 insertions(+), 307 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 2f23fe743ec..47b5d6cecaa 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -465,36 +465,6 @@ 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." @@ -535,8 +505,9 @@ Return the compile-time value of FORM." byte-compile-new-defuns)) (setf result (byte-compile-eval - (byte-compile-top-level - (byte-compile-preprocess form))))))) + (macroexp-strip-symbol-positions + (byte-compile-top-level + (byte-compile-preprocess form)))))))) (list 'quote result)))) (eval-and-compile . ,(lambda (&rest body) (byte-compile-recurse-toplevel @@ -547,10 +518,13 @@ Return the compile-time value of FORM." ;; or byte-compile-file-form. (let* ((print-symbols-bare t) (expanded - (macroexpand-all - form - macroexpand-all-environment))) - (eval expanded lexical-binding) + (macroexpand-all + form + macroexpand-all-environment))) + (eval + (macroexp-strip-symbol-positions + expanded) + lexical-binding) expanded))))) (with-suppressed-warnings . ,(lambda (warnings &rest body) @@ -1435,7 +1409,7 @@ function directly; use `byte-compile-warn' or (defun byte-compile-warn (format &rest args) "Issue a byte compiler warning; use (format-message FORMAT ARGS...) for message." - (setq args (mapcar #'byte-compile-strip-symbol-positions args)) + (setq args (mapcar #'macroexp-strip-symbol-positions args)) (setq format (apply #'format-message format args)) (if byte-compile-error-on-warn (error "%s" format) ; byte-compile-file catches and logs it @@ -2117,175 +2091,179 @@ See also `emacs-lisp-byte-compile-and-load'." ;; Force logging of the file name for each file compiled. (setq byte-compile-last-logged-file nil) - (let ((byte-compile-current-file filename) - (byte-compile-current-group nil) - (set-auto-coding-for-load t) - (byte-compile--seen-defvars nil) - (byte-compile--known-dynamic-vars - (byte-compile--load-dynvars (getenv "EMACS_DYNVARS_FILE"))) - target-file input-buffer output-buffer - byte-compile-dest-file byte-compiler-error-flag) - (setq target-file (byte-compile-dest-file filename)) - (setq byte-compile-dest-file target-file) - (with-current-buffer - ;; It would be cleaner to use a temp buffer, but if there was - ;; an error, we leave this buffer around for diagnostics. - ;; Its name is documented in the lispref. - (setq input-buffer (get-buffer-create - (concat " *Compiler Input*" - (if (zerop byte-compile-level) "" - (format "-%s" byte-compile-level))))) - (erase-buffer) - (setq buffer-file-coding-system nil) - ;; Always compile an Emacs Lisp file as multibyte - ;; unless the file itself forces unibyte with -*-coding: raw-text;-*- - (set-buffer-multibyte t) - (insert-file-contents filename) - ;; Mimic the way after-insert-file-set-coding can make the - ;; buffer unibyte when visiting this file. - (when (or (eq last-coding-system-used 'no-conversion) - (eq (coding-system-type last-coding-system-used) 5)) - ;; For coding systems no-conversion and raw-text..., - ;; edit the buffer as unibyte. - (set-buffer-multibyte nil)) - ;; Run hooks including the uncompression hook. - ;; If they change the file name, then change it for the output also. - (let ((buffer-file-name filename) - (dmm (default-value 'major-mode)) - ;; Ignore unsafe local variables. - ;; We only care about a few of them for our purposes. - (enable-local-variables :safe) - (enable-local-eval nil)) - (unwind-protect - (progn - (setq-default major-mode 'emacs-lisp-mode) - ;; Arg of t means don't alter enable-local-variables. - (delay-mode-hooks (normal-mode t))) - (setq-default major-mode dmm)) - ;; There may be a file local variable setting (bug#10419). - (setq buffer-read-only nil - filename buffer-file-name)) - ;; Don't inherit lexical-binding from caller (bug#12938). - (unless (local-variable-p 'lexical-binding) - (setq-local lexical-binding nil)) - ;; Set the default directory, in case an eval-when-compile uses it. - (setq default-directory (file-name-directory filename))) - ;; Check if the file's local variables explicitly specify not to - ;; compile this file. - (if (with-current-buffer input-buffer no-byte-compile) - (progn - ;; (message "%s not compiled because of `no-byte-compile: %s'" - ;; (byte-compile-abbreviate-file filename) - ;; (with-current-buffer input-buffer no-byte-compile)) - (when (and target-file (file-exists-p target-file)) - (message "%s deleted because of `no-byte-compile: %s'" - (byte-compile-abbreviate-file target-file) - (buffer-local-value 'no-byte-compile input-buffer)) - (condition-case nil (delete-file target-file) (error nil))) - ;; We successfully didn't compile this file. - 'no-byte-compile) - (when byte-compile-verbose - (message "Compiling %s..." filename)) - ;; It is important that input-buffer not be current at this call, - ;; so that the value of point set in input-buffer - ;; within byte-compile-from-buffer lingers in that buffer. - (setq output-buffer - (save-current-buffer - (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 - (when byte-compile-verbose - (message "Compiling %s...done" filename)) - (kill-buffer input-buffer) - (with-current-buffer output-buffer - (when (and target-file - (or (not byte-native-compiling) - (and byte-native-compiling byte+native-compile))) - (goto-char (point-max)) - (insert "\n") ; aaah, unix. - (cond - ((and (file-writable-p target-file) - ;; We attempt to create a temporary file in the - ;; target directory, so the target directory must be - ;; writable. - (file-writable-p - (file-name-directory - ;; Need to expand in case TARGET-FILE doesn't - ;; include a directory (Bug#45287). - (expand-file-name target-file)))) - ;; We must disable any code conversion here. - (let* ((coding-system-for-write 'no-conversion) - ;; Write to a tempfile so that if another Emacs - ;; process is trying to load target-file (eg in a - ;; parallel bootstrap), it does not risk getting a - ;; half-finished file. (Bug#4196) - (tempfile - (make-temp-file (when (file-writable-p target-file) - (expand-file-name target-file)))) - (default-modes (default-file-modes)) - (temp-modes (logand default-modes #o600)) - (desired-modes (logand default-modes #o666)) - (kill-emacs-hook - (cons (lambda () (ignore-errors - (delete-file tempfile))) - kill-emacs-hook))) - (unless (= temp-modes desired-modes) - (set-file-modes tempfile desired-modes 'nofollow)) - (write-region (point-min) (point-max) tempfile nil 1) - ;; This has the intentional side effect that any - ;; hard-links to target-file continue to - ;; point to the old file (this makes it possible - ;; for installed files to share disk space with - ;; the build tree, without causing problems when - ;; emacs-lisp files in the build tree are - ;; recompiled). Previously this was accomplished by - ;; deleting target-file before writing it. - (if byte-native-compiling - ;; Defer elc final renaming. - (setf byte-to-native-output-file - (cons tempfile target-file)) - (rename-file tempfile target-file t))) - (or noninteractive - byte-native-compiling - (message "Wrote %s" target-file))) - ((file-writable-p target-file) - ;; In case the target directory isn't writable (see e.g. Bug#44631), - ;; try writing to the output file directly. We must disable any - ;; code conversion here. - (let ((coding-system-for-write 'no-conversion)) - (with-file-modes (logand (default-file-modes) #o666) - (write-region (point-min) (point-max) target-file nil 1))) - (or noninteractive (message "Wrote %s" target-file))) - (t - ;; This is just to give a better error message than write-region - (let ((exists (file-exists-p target-file))) - (signal (if exists 'file-error 'file-missing) - (list "Opening output file" - (if exists - "Cannot overwrite file" - "Directory not writable or nonexistent") - target-file)))))) - (kill-buffer (current-buffer))) - (if (and byte-compile-generate-call-tree - (or (eq t byte-compile-generate-call-tree) - (y-or-n-p (format "Report call tree for %s? " - filename)))) - (save-excursion - (display-call-tree filename))) - (let ((gen-dynvars (getenv "EMACS_GENERATE_DYNVARS"))) - (when (and gen-dynvars (not (equal gen-dynvars "")) - byte-compile--seen-defvars) - (let ((dynvar-file (concat target-file ".dynvars"))) - (message "Generating %s" dynvar-file) - (with-temp-buffer - (dolist (var (delete-dups byte-compile--seen-defvars)) - (insert (format "%S\n" (cons var filename)))) - (write-region (point-min) (point-max) dynvar-file))))) - (if load - (load target-file)) - t)))) + (prog1 + (let ((byte-compile-current-file filename) + (byte-compile-current-group nil) + (set-auto-coding-for-load t) + (byte-compile--seen-defvars nil) + (byte-compile--known-dynamic-vars + (byte-compile--load-dynvars (getenv "EMACS_DYNVARS_FILE"))) + target-file input-buffer output-buffer + byte-compile-dest-file byte-compiler-error-flag) + (setq target-file (byte-compile-dest-file filename)) + (setq byte-compile-dest-file target-file) + (with-current-buffer + ;; It would be cleaner to use a temp buffer, but if there was + ;; an error, we leave this buffer around for diagnostics. + ;; Its name is documented in the lispref. + (setq input-buffer (get-buffer-create + (concat " *Compiler Input*" + (if (zerop byte-compile-level) "" + (format "-%s" byte-compile-level))))) + (erase-buffer) + (setq buffer-file-coding-system nil) + ;; Always compile an Emacs Lisp file as multibyte + ;; unless the file itself forces unibyte with -*-coding: raw-text;-*- + (set-buffer-multibyte t) + (insert-file-contents filename) + ;; Mimic the way after-insert-file-set-coding can make the + ;; buffer unibyte when visiting this file. + (when (or (eq last-coding-system-used 'no-conversion) + (eq (coding-system-type last-coding-system-used) 5)) + ;; For coding systems no-conversion and raw-text..., + ;; edit the buffer as unibyte. + (set-buffer-multibyte nil)) + ;; Run hooks including the uncompression hook. + ;; If they change the file name, then change it for the output also. + (let ((buffer-file-name filename) + (dmm (default-value 'major-mode)) + ;; Ignore unsafe local variables. + ;; We only care about a few of them for our purposes. + (enable-local-variables :safe) + (enable-local-eval nil)) + (unwind-protect + (progn + (setq-default major-mode 'emacs-lisp-mode) + ;; Arg of t means don't alter enable-local-variables. + (delay-mode-hooks (normal-mode t))) + (setq-default major-mode dmm)) + ;; There may be a file local variable setting (bug#10419). + (setq buffer-read-only nil + filename buffer-file-name)) + ;; Don't inherit lexical-binding from caller (bug#12938). + (unless (local-variable-p 'lexical-binding) + (setq-local lexical-binding nil)) + ;; Set the default directory, in case an eval-when-compile uses it. + (setq default-directory (file-name-directory filename))) + ;; Check if the file's local variables explicitly specify not to + ;; compile this file. + (if (with-current-buffer input-buffer no-byte-compile) + (progn + ;; (message "%s not compiled because of `no-byte-compile: %s'" + ;; (byte-compile-abbreviate-file filename) + ;; (with-current-buffer input-buffer no-byte-compile)) + (when (and target-file (file-exists-p target-file)) + (message "%s deleted because of `no-byte-compile: %s'" + (byte-compile-abbreviate-file target-file) + (buffer-local-value 'no-byte-compile input-buffer)) + (condition-case nil (delete-file target-file) (error nil))) + ;; We successfully didn't compile this file. + 'no-byte-compile) + (when byte-compile-verbose + (message "Compiling %s..." filename)) + ;; It is important that input-buffer not be current at this call, + ;; so that the value of point set in input-buffer + ;; within byte-compile-from-buffer lingers in that buffer. + (setq output-buffer + (save-current-buffer + (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 + (when byte-compile-verbose + (message "Compiling %s...done" filename)) + (kill-buffer input-buffer) + (with-current-buffer output-buffer + (when (and target-file + (or (not byte-native-compiling) + (and byte-native-compiling byte+native-compile))) + (goto-char (point-max)) + (insert "\n") ; aaah, unix. + (cond + ((and (file-writable-p target-file) + ;; We attempt to create a temporary file in the + ;; target directory, so the target directory must be + ;; writable. + (file-writable-p + (file-name-directory + ;; Need to expand in case TARGET-FILE doesn't + ;; include a directory (Bug#45287). + (expand-file-name target-file)))) + ;; We must disable any code conversion here. + (let* ((coding-system-for-write 'no-conversion) + ;; Write to a tempfile so that if another Emacs + ;; process is trying to load target-file (eg in a + ;; parallel bootstrap), it does not risk getting a + ;; half-finished file. (Bug#4196) + (tempfile + (make-temp-file (when (file-writable-p target-file) + (expand-file-name target-file)))) + (default-modes (default-file-modes)) + (temp-modes (logand default-modes #o600)) + (desired-modes (logand default-modes #o666)) + (kill-emacs-hook + (cons (lambda () (ignore-errors + (delete-file tempfile))) + kill-emacs-hook))) + (unless (= temp-modes desired-modes) + (set-file-modes tempfile desired-modes 'nofollow)) + (write-region (point-min) (point-max) tempfile nil 1) + ;; This has the intentional side effect that any + ;; hard-links to target-file continue to + ;; point to the old file (this makes it possible + ;; for installed files to share disk space with + ;; the build tree, without causing problems when + ;; emacs-lisp files in the build tree are + ;; recompiled). Previously this was accomplished by + ;; deleting target-file before writing it. + (if byte-native-compiling + ;; Defer elc final renaming. + (setf byte-to-native-output-file + (cons tempfile target-file)) + (rename-file tempfile target-file t))) + (or noninteractive + byte-native-compiling + (message "Wrote %s" target-file))) + ((file-writable-p target-file) + ;; In case the target directory isn't writable (see e.g. Bug#44631), + ;; try writing to the output file directly. We must disable any + ;; code conversion here. + (let ((coding-system-for-write 'no-conversion)) + (with-file-modes (logand (default-file-modes) #o666) + (write-region (point-min) (point-max) target-file nil 1))) + (or noninteractive (message "Wrote %s" target-file))) + (t + ;; This is just to give a better error message than write-region + (let ((exists (file-exists-p target-file))) + (signal (if exists 'file-error 'file-missing) + (list "Opening output file" + (if exists + "Cannot overwrite file" + "Directory not writable or nonexistent") + target-file)))))) + (kill-buffer (current-buffer))) + (if (and byte-compile-generate-call-tree + (or (eq t byte-compile-generate-call-tree) + (y-or-n-p (format "Report call tree for %s? " + filename)))) + (save-excursion + (display-call-tree filename))) + (let ((gen-dynvars (getenv "EMACS_GENERATE_DYNVARS"))) + (when (and gen-dynvars (not (equal gen-dynvars "")) + byte-compile--seen-defvars) + (let ((dynvar-file (concat target-file ".dynvars"))) + (message "Generating %s" dynvar-file) + (with-temp-buffer + (dolist (var (delete-dups byte-compile--seen-defvars)) + (insert (format "%S\n" (cons var filename)))) + (write-region (point-min) (point-max) dynvar-file))))) + (if load + (load target-file)) + t))) + ;; Strip positions from symbols for the native compiler. + (setq byte-to-native-top-level-forms + (macroexp-strip-symbol-positions byte-to-native-top-level-forms)))) ;;; compiling a single function ;;;###autoload @@ -2458,8 +2436,10 @@ Call from the source buffer." ;; it here. (when byte-native-compiling ;; Spill output for the native compiler here - (push (make-byte-to-native-top-level :form form :lexical lexical-binding) - byte-to-native-top-level-forms)) + (push + (macroexp-strip-symbol-positions + (make-byte-to-native-top-level :form form :lexical lexical-binding)) + byte-to-native-top-level-forms)) (let ((print-escape-newlines t) (print-length nil) (print-level nil) @@ -2659,7 +2639,7 @@ 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 (byte-compile-strip-symbol-positions + (push (macroexp-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, @@ -2676,7 +2656,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 (byte-compile-strip-symbol-positions form) + (prog1 (macroexp-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))) @@ -2717,7 +2697,7 @@ list that represents a doc string reference. ((symbolp (nth 2 form)) (setcar (cddr form) (bare-symbol (nth 2 form)))) (t (setcar (cddr form) - (byte-compile-strip-symbol-positions (nth 2 form))))) + (macroexp-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)))) @@ -2800,7 +2780,7 @@ list that represents a doc string reference. (prog1 (byte-compile-keep-pending form) (apply 'make-obsolete (mapcar 'eval - (byte-compile-strip-symbol-positions (cdr form)))))) + (macroexp-strip-symbol-positions (cdr form)))))) ;; This handler is not necessary, but it makes the output from dont-compile ;; and similar macros cleaner. @@ -2926,13 +2906,15 @@ not to take responsibility for the actual compilation of the code." (if (not (stringp (documentation code t))) -1 4))) (when byte-native-compiling ;; Spill output for the native compiler here. - (push (if macro - (make-byte-to-native-top-level - :form `(defalias ',name '(macro . ,code) nil) - :lexical lexical-binding) - (make-byte-to-native-func-def :name name - :byte-func code)) - byte-to-native-top-level-forms)) + (push + (macroexp-strip-symbol-positions + (if macro + (make-byte-to-native-top-level + :form `(defalias ',name '(macro . ,code) nil) + :lexical lexical-binding) + (make-byte-to-native-func-def :name name + :byte-func code))) + byte-to-native-top-level-forms)) ;; Output the form by hand, that's much simpler than having ;; b-c-output-file-form analyze the defalias. (byte-compile-output-docform @@ -3020,37 +3002,40 @@ If FORM is a lambda or a macro, byte-compile it as a function." (macro (eq (car-safe fun) 'macro))) (if macro (setq fun (cdr fun))) - (cond - ;; Up until Emacs-24.1, byte-compile silently did nothing when asked to - ;; compile something invalid. So let's tune down the complaint from an - ;; error to a simple message for the known case where signaling an error - ;; causes problems. - ((byte-code-function-p fun) - (message "Function %s is already compiled" - (if (symbolp form) form "provided")) - fun) - (t - (let (final-eval) - (when (or (symbolp form) (eq (car-safe fun) 'closure)) - ;; `fun' is a function *value*, so try to recover its corresponding - ;; source code. - (setq lexical-binding (eq (car fun) 'closure)) - (setq fun (byte-compile--reify-function fun)) - (setq final-eval t)) - ;; Expand macros. - (setq fun (byte-compile-preprocess fun)) - (setq fun (byte-compile-top-level fun nil 'eval)) - (if (symbolp form) - ;; byte-compile-top-level returns an *expression* equivalent to the - ;; `fun' expression, so we need to evaluate it, tho normally - ;; this is not needed because the expression is just a constant - ;; byte-code object, which is self-evaluating. - (setq fun (eval fun t))) - (if final-eval - (setq fun (eval fun t))) - (if macro (push 'macro fun)) - (if (symbolp form) (fset form fun)) - fun))))))) + (prog1 + (cond + ;; Up until Emacs-24.1, byte-compile silently did nothing when asked to + ;; compile something invalid. So let's tune down the complaint from an + ;; error to a simple message for the known case where signaling an error + ;; causes problems. + ((byte-code-function-p fun) + (message "Function %s is already compiled" + (if (symbolp form) form "provided")) + fun) + (t + (let (final-eval) + (when (or (symbolp form) (eq (car-safe fun) 'closure)) + ;; `fun' is a function *value*, so try to recover its corresponding + ;; source code. + (setq lexical-binding (eq (car fun) 'closure)) + (setq fun (byte-compile--reify-function fun)) + (setq final-eval t)) + ;; Expand macros. + (setq fun (byte-compile-preprocess fun)) + (setq fun (byte-compile-top-level fun nil 'eval)) + (if (symbolp form) + ;; byte-compile-top-level returns an *expression* equivalent to the + ;; `fun' expression, so we need to evaluate it, tho normally + ;; this is not needed because the expression is just a constant + ;; byte-code object, which is self-evaluating. + (setq fun (eval fun t))) + (if final-eval + (setq fun (eval fun t))) + (if macro (push 'macro fun)) + (if (symbolp form) (fset form fun)) + fun))) + (setq byte-to-native-top-level-forms + (macroexp-strip-symbol-positions byte-to-native-top-level-forms))))))) (defun byte-compile-sexp (sexp) "Compile and return SEXP." @@ -3197,8 +3182,8 @@ for symbols generated by the byte compiler itself." ;; 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))))) + (setq int (macroexp-strip-symbol-positions `(interactive ,newform))) + (setq int (macroexp-strip-symbol-positions int))))) ((cdr int) ; Invalid (interactive . something). (byte-compile-warn-x int "malformed interactive spec: %s" int)))) @@ -3213,7 +3198,7 @@ for symbols generated by the byte compiler itself." (byte-compile-make-lambda-lexenv arglistvars)) reserved-csts)) - (bare-arglist (byte-compile-strip-symbol-positions arglist))) + (bare-arglist (macroexp-strip-symbol-positions arglist))) ;; Build the actual byte-coded function. (cl-assert (eq 'byte-code (car-safe compiled))) (let ((out @@ -3237,7 +3222,7 @@ for symbols generated by the byte compiler itself." ;; We have some command modes, so use the vector form. (command-modes (list (vector (nth 1 int) - (byte-compile-strip-symbol-positions + (macroexp-strip-symbol-positions command-modes)))) ;; No command modes, use the simple form with just the ;; interactive spec. @@ -3785,7 +3770,7 @@ assignment (i.e. `setq')." (byte-compile-out 'byte-constant (byte-compile-get-constant - (byte-compile-strip-symbol-positions const)))) + (macroexp-strip-symbol-positions const)))) ;; Compile those primitive ordinary functions ;; which have special byte codes just for speed. @@ -4619,7 +4604,7 @@ Return (TAIL VAR TEST CASES), where: (dolist (case cases) (setq tag (byte-compile-make-tag) - test-objects (byte-compile-strip-symbol-positions (car case)) + test-objects (macroexp-strip-symbol-positions (car case)) body (cdr case)) (byte-compile-out-tag tag) (dolist (value test-objects) @@ -5265,7 +5250,7 @@ binding slots have been popped." (when (null form) (byte-compile-warn-x form "Uneven number of key bindings in %S" form)) (push (pop form) result)) - (byte-compile-strip-symbol-positions orig-form))) + (macroexp-strip-symbol-positions orig-form))) (put 'define-keymap--define 'byte-hunk-handler #'byte-compile-define-keymap--define) @@ -5332,9 +5317,9 @@ OP and OPERAND are as passed to `byte-compile-out'." ;;; call tree stuff (defun byte-compile-annotate-call-tree (form) - (let ((current-form (byte-compile-strip-symbol-positions + (let ((current-form (macroexp-strip-symbol-positions byte-compile-current-form)) - (bare-car-form (byte-compile-strip-symbol-positions (car form))) + (bare-car-form (macroexp-strip-symbol-positions (car form))) entry) ;; annotate the current call (if (setq entry (assq bare-car-form byte-compile-call-tree)) @@ -5552,8 +5537,10 @@ already up-to-date." (or (not (file-exists-p dest)) (file-newer-than-file-p source dest)))) (if (null (batch-byte-compile-file (car command-line-args-left))) - (setq error t)))) + (setq error t)))) (setq command-line-args-left (cdr command-line-args-left))) + (setq byte-to-native-top-level-forms + (macroexp-strip-symbol-positions byte-to-native-top-level-forms)) (kill-emacs (if error 1 0)))) (defun batch-byte-compile-file (file) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 3659a0c95a2..fbcf0020e88 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -53,36 +53,6 @@ `(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) @@ -3534,8 +3504,9 @@ and then returning foo." `(eval-and-compile ;; Name the compiler-macro function, so that `symbol-file' can find it. (cl-defun ,fname ,(if (memq '&whole args) (delq '&whole args) - (cons '_cl-whole-arg args)) - ,@body) + (cons '_cl-whole-arg + (macroexp-strip-symbol-positions args))) + ,@(macroexp-strip-symbol-positions body)) (put ',func 'compiler-macro #',fname)))) ;;;###autoload diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 0a105052570..8581fe80662 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -1829,9 +1829,7 @@ and the annotation emission." (byte-listp auto) (byte-eq auto) (byte-memq auto) - (byte-not - (comp-emit-set-call (comp-call 'eq (comp-slot-n (comp-sp)) - (make-comp-mvar :constant nil)))) + (byte-not null) (byte-car auto) (byte-cdr auto) (byte-cons auto) @@ -4017,6 +4015,7 @@ the deferred compilation mechanism." (let* ((data function-or-file) (comp-native-compiling t) (byte-native-qualities nil) + (symbols-with-pos-enabled t) ;; Have byte compiler signal an error when compilation fails. (byte-compile-debug t) (comp-ctxt (make-comp-ctxt :output output @@ -4060,10 +4059,10 @@ the deferred compilation mechanism." (signal (car err) (if (consp err-val) (cons function-or-file err-val) (list function-or-file err-val))))))) - (if (stringp function-or-file) - data - ;; So we return the compiled function. - (native-elisp-load data))))) + (if (stringp function-or-file) + data + ;; So we return the compiled function. + (native-elisp-load data))))) (defun native-compile-async-skip-p (file load selector) "Return non-nil if FILE's compilation should be skipped. diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 60fac981308..dafd5497639 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -32,6 +32,64 @@ ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) +(defvar byte-compile--ssp-conses-seen nil + "Which conses have been processed in a strip-symbol-positions operation?") +(defvar byte-compile--ssp-vectors-seen nil + "Which vectors have been processed in a strip-symbol-positions operation?") +(defvar byte-compile--ssp-records-seen nil + "Which records have been processed in a strip-symbol-positions operation?") + +(defun macroexp--strip-s-p-2 (arg) + "Strip all positions from symbols in ARG, destructively modifying ARG. +Return the modified ARG." + (cond + ((symbolp arg) + (bare-symbol arg)) + ((consp arg) + (unless (memq arg byte-compile--ssp-conses-seen) + ;; (push arg byte-compile--ssp-conses-seen) + (let ((a arg)) + (while (consp (cdr a)) + (setcar a (macroexp--strip-s-p-2 (car a))) + (setq a (cdr a))) + (setcar a (macroexp--strip-s-p-2 (car a))) + ;; (if (cdr a) + (unless (bare-symbol-p (cdr a)) ; includes (unpositioned) nil. + (setcdr a (macroexp--strip-s-p-2 (cdr a)))))) + arg) + ((vectorp arg) + (unless (memq arg byte-compile--ssp-vectors-seen) + (push arg byte-compile--ssp-vectors-seen) + (let ((i 0) + (len (length arg))) + (while (< i len) + (aset arg i (macroexp--strip-s-p-2 (aref arg i))) + (setq i (1+ i))))) + arg) + ((recordp arg) + (unless (memq arg byte-compile--ssp-records-seen) + (push arg byte-compile--ssp-records-seen) + (let ((i 0) + (len (length arg))) + (while (< i len) + (aset arg i (macroexp--strip-s-p-2 (aref arg i))) + (setq i (1+ i))))) + arg) + (t arg))) + +(defun byte-compile-strip-s-p-1 (arg) + "Strip all positions from symbols in ARG, destructively modifying ARG. +Return the modified ARG." + (setq byte-compile--ssp-conses-seen nil) + (setq byte-compile--ssp-vectors-seen nil) + (setq byte-compile--ssp-records-seen nil) + (macroexp--strip-s-p-2 arg)) + +(defun macroexp-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 macroexp--cons (car cdr original-cons) "Return ORIGINAL-CONS if the car/cdr of it is `eq' to CAR and CDR, respectively. If not, return (CAR . CDR)." @@ -96,10 +154,11 @@ each clause." (defun macroexp--compiler-macro (handler form) (condition-case-unless-debug err - (apply handler form (cdr form)) + (let ((symbols-with-pos-enabled t)) + (apply handler form (cdr form))) (error - (message "Compiler-macro error for %S: %S" (car form) err) - form))) + (message "Compiler-macro error for %S: Handler: %S\n%S" (car form) handler err) + form))) (defun macroexp--funcall-if-compiled (_form) "Pseudo function used internally by macroexp to delay warnings. @@ -683,6 +742,7 @@ test of free variables in the following ways: (defun internal-macroexpand-for-load (form full-p) ;; Called from the eager-macroexpansion in readevalloop. + (setq form (macroexp-strip-symbol-positions form)) (cond ;; Don't repeat the same warning for every top-level element. ((eq 'skip (car macroexp--pending-eager-loads)) form) diff --git a/src/comp.c b/src/comp.c index 5b947fc99b6..ac38c2131f9 100644 --- a/src/comp.c +++ b/src/comp.c @@ -454,6 +454,7 @@ load_gccjit_if_necessary (bool mandatory) /* C symbols emitted for the load relocation mechanism. */ #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" +#define F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM "f_symbols_with_pos_enabled_reloc" #define PURE_RELOC_SYM "pure_reloc" #define DATA_RELOC_SYM "d_reloc" #define DATA_RELOC_IMPURE_SYM "d_reloc_imp" @@ -542,6 +543,7 @@ typedef struct { gcc_jit_type *emacs_int_type; gcc_jit_type *emacs_uint_type; gcc_jit_type *void_ptr_type; + gcc_jit_type *bool_ptr_type; gcc_jit_type *char_ptr_type; gcc_jit_type *ptrdiff_type; gcc_jit_type *uintptr_type; @@ -563,6 +565,15 @@ typedef struct { gcc_jit_field *lisp_cons_u_s_u_cdr; gcc_jit_type *lisp_cons_type; gcc_jit_type *lisp_cons_ptr_type; + /* struct Lisp_Symbol_With_Position */ + gcc_jit_rvalue *f_symbols_with_pos_enabled_ref; + gcc_jit_struct *lisp_symbol_with_position; + gcc_jit_field *lisp_symbol_with_position_header; + gcc_jit_field *lisp_symbol_with_position_sym; + gcc_jit_field *lisp_symbol_with_position_pos; + gcc_jit_type *lisp_symbol_with_position_type; + gcc_jit_type *lisp_symbol_with_position_ptr_type; + gcc_jit_function *get_symbol_with_position; /* struct jmp_buf. */ gcc_jit_struct *jmp_buf_s; /* struct handler. */ @@ -655,7 +666,10 @@ Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); Lisp_Object helper_unbind_n (Lisp_Object n); void helper_save_restriction (void); bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code); +struct Lisp_Symbol_With_Pos *helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a); +/* Note: helper_link_table must match the list created by + `declare_runtime_imported_funcs'. */ void *helper_link_table[] = { wrong_type_argument, helper_PSEUDOVECTOR_TYPEP_XUNTAG, @@ -664,6 +678,7 @@ void *helper_link_table[] = record_unwind_protect_excursion, helper_unbind_n, helper_save_restriction, + helper_GET_SYMBOL_WITH_POSITION, record_unwind_current_buffer, set_internal, helper_unwind_protect, @@ -1328,9 +1343,9 @@ emit_XCONS (gcc_jit_rvalue *a) } static gcc_jit_rvalue * -emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) +emit_BASE_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) { - emit_comment ("EQ"); + emit_comment ("BASE_EQ"); return gcc_jit_context_new_comparison ( comp.ctxt, @@ -1340,6 +1355,30 @@ emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) emit_XLI (y)); } +static gcc_jit_rvalue * +emit_AND (gcc_jit_rvalue *x, gcc_jit_rvalue *y) +{ + return gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + x, + y); +} + +static gcc_jit_rvalue * +emit_OR (gcc_jit_rvalue *x, gcc_jit_rvalue *y) +{ + return gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + x, + y); +} + static gcc_jit_rvalue * emit_TAGGEDP (gcc_jit_rvalue *obj, Lisp_Word_tag tag) { @@ -1401,6 +1440,94 @@ emit_CONSP (gcc_jit_rvalue *obj) return emit_TAGGEDP (obj, Lisp_Cons); } +static gcc_jit_rvalue * +emit_BARE_SYMBOL_P (gcc_jit_rvalue *obj) +{ + emit_comment ("BARE_SYMBOL_P"); + + return gcc_jit_context_new_cast (comp.ctxt, + NULL, + emit_TAGGEDP (obj, Lisp_Symbol), + comp.bool_type); +} + +static gcc_jit_rvalue * +emit_SYMBOL_WITH_POS_P (gcc_jit_rvalue *obj) +{ + emit_comment ("SYMBOL_WITH_POS_P"); + + gcc_jit_rvalue *args[] = + { obj, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + PVEC_SYMBOL_WITH_POS) + }; + + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.pseudovectorp, + 2, + args); +} + +static gcc_jit_rvalue * +emit_SYMBOL_WITH_POS_SYM (gcc_jit_rvalue *obj) +{ + emit_comment ("SYMBOL_WITH_POS_SYM"); + + gcc_jit_rvalue *tmp2, *swp; + gcc_jit_lvalue *tmpl; + + gcc_jit_rvalue *args[] = { obj }; + swp = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.get_symbol_with_position, + 1, + args); + tmpl = gcc_jit_rvalue_dereference (swp, gcc_jit_context_new_location (comp.ctxt, "comp.c", __LINE__, 0)); + tmp2 = gcc_jit_lvalue_as_rvalue (tmpl); + return + gcc_jit_rvalue_access_field (tmp2, + NULL, + comp.lisp_symbol_with_position_sym); +} + +static gcc_jit_rvalue * +emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) +{ + return + emit_OR ( + gcc_jit_context_new_comparison ( + comp.ctxt, gcc_jit_context_new_location (comp.ctxt, "comp.c", __LINE__, 0), + GCC_JIT_COMPARISON_EQ, + emit_XLI (x), emit_XLI (y)), + emit_AND ( + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.f_symbols_with_pos_enabled_ref, + gcc_jit_context_new_location (comp.ctxt, "comp.c", __LINE__, 0))), + emit_OR ( + emit_AND ( + emit_SYMBOL_WITH_POS_P (x), + emit_OR ( + emit_AND ( + emit_SYMBOL_WITH_POS_P (y), + emit_BASE_EQ ( + emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)), + emit_XLI (emit_SYMBOL_WITH_POS_SYM (y)))), + emit_AND ( + emit_BARE_SYMBOL_P (y), + emit_BASE_EQ ( + emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)), + emit_XLI (y))))), + emit_AND ( + emit_BARE_SYMBOL_P (x), + emit_AND ( + emit_SYMBOL_WITH_POS_P (y), + emit_BASE_EQ ( + emit_XLI (x), + emit_XLI (emit_SYMBOL_WITH_POS_SYM (y)))))))); +} + static gcc_jit_rvalue * emit_FLOATP (gcc_jit_rvalue *obj) { @@ -1615,7 +1742,7 @@ static gcc_jit_rvalue * emit_NILP (gcc_jit_rvalue *x) { emit_comment ("NILP"); - return emit_EQ (x, emit_lisp_obj_rval (Qnil)); + return emit_BASE_EQ (x, emit_lisp_obj_rval (Qnil)); } static gcc_jit_rvalue * @@ -2095,7 +2222,13 @@ emit_limple_insn (Lisp_Object insn) gcc_jit_block *target1 = retrive_block (arg[2]); gcc_jit_block *target2 = retrive_block (arg[3]); - emit_cond_jump (emit_EQ (a, b), target1, target2); + if ((CALL1I (comp-cstr-imm-vld-p, arg[0]) + && NILP (CALL1I (comp-cstr-imm, arg[0]))) + || (CALL1I (comp-cstr-imm-vld-p, arg[1]) + && NILP (CALL1I (comp-cstr-imm, arg[1])))) + emit_cond_jump (emit_BASE_EQ (a, b), target1, target2); + else + emit_cond_jump (emit_EQ (a, b), target1, target2); } else if (EQ (op, Qcond_jump_narg_leq)) { @@ -2714,7 +2847,8 @@ declare_imported_data (void) /* Declare as imported all the functions that are requested from the runtime. - These are either subrs or not. + These are either subrs or not. Note that the list created here must match + the array `helper_link_table'. */ static Lisp_Object declare_runtime_imported_funcs (void) @@ -2751,6 +2885,10 @@ declare_runtime_imported_funcs (void) ADD_IMPORTED (helper_save_restriction, comp.void_type, 0, NULL); + args[0] = comp.lisp_obj_type; + ADD_IMPORTED (helper_GET_SYMBOL_WITH_POSITION, comp.lisp_symbol_with_position_ptr_type, + 1, args); + ADD_IMPORTED (record_unwind_current_buffer, comp.void_type, 0, NULL); args[0] = args[1] = args[2] = comp.lisp_obj_type; @@ -2798,6 +2936,15 @@ emit_ctxt_code (void) gcc_jit_type_get_pointer (comp.thread_state_ptr_type), CURRENT_THREAD_RELOC_SYM)); + comp.f_symbols_with_pos_enabled_ref = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + comp.bool_ptr_type, + F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM)); + comp.pure_ptr = gcc_jit_lvalue_as_rvalue ( gcc_jit_context_new_global ( @@ -2977,6 +3124,39 @@ define_lisp_cons (void) } +static void +define_lisp_symbol_with_position (void) +{ + comp.lisp_symbol_with_position_header = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.ptrdiff_type, + "header"); + comp.lisp_symbol_with_position_sym = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "sym"); + comp.lisp_symbol_with_position_pos = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "pos"); + gcc_jit_field *fields [3] = {comp.lisp_symbol_with_position_header, + comp.lisp_symbol_with_position_sym, + comp.lisp_symbol_with_position_pos}; + comp.lisp_symbol_with_position = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "comp_lisp_symbol_with_position", + 3, + fields); + comp.lisp_symbol_with_position_type = + gcc_jit_struct_as_type (comp.lisp_symbol_with_position); + comp.lisp_symbol_with_position_ptr_type = + gcc_jit_type_get_pointer (comp.lisp_symbol_with_position_type); +} + /* Opaque jmp_buf definition. */ static void @@ -3672,6 +3852,40 @@ define_PSEUDOVECTORP (void) comp.bool_type, 2, args, false)); } +static void +define_GET_SYMBOL_WITH_POSITION (void) +{ + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "a") }; + + comp.get_symbol_with_position = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.lisp_symbol_with_position_ptr_type, + "GET_SYMBOL_WITH_POSITION", + 1, + param, + 0); + + DECL_BLOCK (entry_block, comp.get_symbol_with_position); + + comp.block = entry_block; + comp.func = comp.get_symbol_with_position; + + gcc_jit_rvalue *args[] = + { gcc_jit_param_as_rvalue (param[0]) }; + /* FIXME use XUNTAG now that's available. */ + gcc_jit_block_end_with_return ( + entry_block, + NULL, + emit_call (intern_c_string ("helper_GET_SYMBOL_WITH_POSITION"), + comp.lisp_symbol_with_position_ptr_type, + 1, args, false)); +} + static void define_CHECK_IMPURE (void) { @@ -4309,6 +4523,7 @@ Return t on success. */) gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG_LONG); comp.unsigned_long_long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG); + comp.bool_ptr_type = gcc_jit_type_get_pointer (comp.bool_type); comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type); comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt, sizeof (EMACS_INT), @@ -4381,6 +4596,7 @@ Return t on success. */) /* Define data structures. */ define_lisp_cons (); + define_lisp_symbol_with_position (); define_jmp_buf (); define_handler_struct (); define_thread_state_struct (); @@ -4602,6 +4818,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, /* Define inline functions. */ define_CAR_CDR (); define_PSEUDOVECTORP (); + define_GET_SYMBOL_WITH_POSITION (); define_CHECK_TYPE (); define_CHECK_IMPURE (); define_bool_to_lisp_obj (); @@ -4734,6 +4951,14 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) code); } +struct Lisp_Symbol_With_Pos * +helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a) +{ + if (!SYMBOL_WITH_POS_P (a)) + wrong_type_argument (Qwrong_type_argument, a); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos); +} + /* `native-comp-eln-load-path' clean-up support code. */ @@ -5018,12 +5243,15 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, { struct thread_state ***current_thread_reloc = dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); + bool **f_symbols_with_pos_enabled_reloc = + dynlib_sym (handle, F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM); void **pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); Lisp_Object *data_imp_relocs = comp_u->data_imp_relocs; void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); if (!(current_thread_reloc + && f_symbols_with_pos_enabled_reloc && pure_reloc && data_relocs && data_imp_relocs @@ -5035,6 +5263,7 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); *current_thread_reloc = ¤t_thread; + *f_symbols_with_pos_enabled_reloc = &symbols_with_pos_enabled; *pure_reloc = pure; /* Imported functions. */ @@ -5541,3 +5770,6 @@ be preloaded. */); defsubr (&Snative_comp_available_p); } +/* Local Variables: */ +/* c-file-offsets: ((arglist-intro . +)) */ +/* End: */ diff --git a/src/fns.c b/src/fns.c index 43df40aa9ed..5df4ecfb368 100644 --- a/src/fns.c +++ b/src/fns.c @@ -2414,6 +2414,11 @@ It can be retrieved with `(get SYMBOL PROPNAME)'. */) (Lisp_Object symbol, Lisp_Object propname, Lisp_Object value) { CHECK_SYMBOL (symbol); + if (symbols_with_pos_enabled) + { + propname = call1 (intern ("macroexp-strip-symbol-positions"), propname); + value = call1 (intern ("macroexp-strip-symbol-positions"), value); + } set_symbol_plist (symbol, Fplist_put (XSYMBOL (symbol)->u.s.plist, propname, value)); return value; -- cgit v1.2.3 From ff9af1f1f69264bcbb7b926363293e55a6b3f330 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Fri, 31 Dec 2021 21:21:46 +0000 Subject: Miscellaneous enhancements to scratch/correct-warning-pos. 1. Check the type (symbol with position) of the argument given to the native compiled version of SYMBOL_WITH_POS_SYM. 2. Handle infinite recursion caused by circular lists, etc., in macroexp-strip-symbol-positions by using hash tables. 3. Read byte compiled functions without giving symbols positions. * lisp/emacs-lisp/comp.el (comp-finalize-relocs): Add symbol-with-pos-p into the list of relocated symbols. * lisp/emacs-lisp/macroexp.el (macroexp--ssp-conses-seen) (macroexp--ssp-vectors-seen, macroexp--ssp-records-seen): Renamed, and animated as hash tables. (macroexp--strip-s-p-2): Optionally tests for the presence of an argument in one of the above hash tables, so as to handle otherwise infinite recursion. (byte-compile-strip-s-p-1): Add a condition-case to handle infinite recursion caused by circular lists etc., using the above hash tables as required. * src/comp.c (comp_t): New element symbol_with_pos_sym. (emit_SYMBOL_WITH_POS_SYM): Amend just to call the new SYMBOL_WITH_POS_SYM. (emit_CHECK_SYMBOL_WITH_POS, define_SYMBOL_WITH_POS_SYM): New functions. (Fcomp__init_ctxt): Register an emitter for Qsymbol_with_pos_p. (Fcomp__compile_ctxt_to_file): Call define_SYMBOL_WITH_POS_SYM. (syms_of_comp): Define Qsymbol_with_pos_p. * src/data.c (syms_of_data): Define a new error symbol Qrecursion_error, an error category for the new error symbols Qexcessive_variable_binding and Qexcessive_lisp_nesting. * src/eval.c (grow_specpdl): Change the signal_error call to an xsignal0 call using the new error symbol Qexcessive_variable_binding. (eval_sub, Ffuncall): Change the `error' calls to xsignal using the new error symbol Qexcessive_lisp_nesting. * src/lread.c (read1): When reading a compiled function, read the components of the vector without giving its symbols a position. --- lisp/emacs-lisp/comp.el | 2 +- lisp/emacs-lisp/macroexp.el | 40 +++++++++++++------- src/comp.c | 90 +++++++++++++++++++++++++++++++++++++-------- src/data.c | 16 +++++++- src/eval.c | 7 ++-- src/lread.c | 2 +- 6 files changed, 122 insertions(+), 35 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 8581fe80662..1912d0d0037 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -3576,7 +3576,7 @@ Update all insn accordingly." ;; Symbols imported by C inlined functions. We do this here because ;; is better to add all objs to the relocation containers before we ;; compacting them. - (mapc #'comp-add-const-to-relocs '(nil t consp listp)) + (mapc #'comp-add-const-to-relocs '(nil t consp listp symbol-with-pos-p)) (let* ((d-default (comp-ctxt-d-default comp-ctxt)) (d-default-idx (comp-data-container-idx d-default)) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index dafd5497639..11204f7f7fb 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -32,11 +32,11 @@ ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) -(defvar byte-compile--ssp-conses-seen nil +(defvar macroexp--ssp-conses-seen nil "Which conses have been processed in a strip-symbol-positions operation?") -(defvar byte-compile--ssp-vectors-seen nil +(defvar macroexp--ssp-vectors-seen nil "Which vectors have been processed in a strip-symbol-positions operation?") -(defvar byte-compile--ssp-records-seen nil +(defvar macroexp--ssp-records-seen nil "Which records have been processed in a strip-symbol-positions operation?") (defun macroexp--strip-s-p-2 (arg) @@ -46,8 +46,10 @@ Return the modified ARG." ((symbolp arg) (bare-symbol arg)) ((consp arg) - (unless (memq arg byte-compile--ssp-conses-seen) - ;; (push arg byte-compile--ssp-conses-seen) + (unless (and macroexp--ssp-conses-seen + (gethash arg macroexp--ssp-conses-seen)) + (if macroexp--ssp-conses-seen + (puthash arg t macroexp--ssp-conses-seen)) (let ((a arg)) (while (consp (cdr a)) (setcar a (macroexp--strip-s-p-2 (car a))) @@ -58,8 +60,10 @@ Return the modified ARG." (setcdr a (macroexp--strip-s-p-2 (cdr a)))))) arg) ((vectorp arg) - (unless (memq arg byte-compile--ssp-vectors-seen) - (push arg byte-compile--ssp-vectors-seen) + (unless (and macroexp--ssp-vectors-seen + (gethash arg macroexp--ssp-vectors-seen)) + (if macroexp--ssp-vectors-seen + (puthash arg t macroexp--ssp-vectors-seen)) (let ((i 0) (len (length arg))) (while (< i len) @@ -67,8 +71,10 @@ Return the modified ARG." (setq i (1+ i))))) arg) ((recordp arg) - (unless (memq arg byte-compile--ssp-records-seen) - (push arg byte-compile--ssp-records-seen) + (unless (and macroexp--ssp-records-seen + (gethash arg macroexp--ssp-records-seen)) + (if macroexp--ssp-records-seen + (puthash arg t macroexp--ssp-records-seen)) (let ((i 0) (len (length arg))) (while (< i len) @@ -80,10 +86,18 @@ Return the modified ARG." (defun byte-compile-strip-s-p-1 (arg) "Strip all positions from symbols in ARG, destructively modifying ARG. Return the modified ARG." - (setq byte-compile--ssp-conses-seen nil) - (setq byte-compile--ssp-vectors-seen nil) - (setq byte-compile--ssp-records-seen nil) - (macroexp--strip-s-p-2 arg)) + (condition-case err + (progn + (setq macroexp--ssp-conses-seen nil) + (setq macroexp--ssp-vectors-seen nil) + (setq macroexp--ssp-records-seen nil) + (macroexp--strip-s-p-2 arg)) + (recursion-error + (dolist (tab '(macroexp--ssp-conses-seen macroexp--ssp-vectors-seen + macroexp--ssp-records-seen)) + (set tab (make-hash-table :test 'eq))) + (macroexp--strip-s-p-2 arg)) + (error (signal (car err) (cdr err))))) (defun macroexp-strip-symbol-positions (arg) "Strip all positions from symbols (recursively) in ARG. Don't modify ARG." diff --git a/src/comp.c b/src/comp.c index ac38c2131f9..834656897e4 100644 --- a/src/comp.c +++ b/src/comp.c @@ -574,6 +574,7 @@ typedef struct { gcc_jit_type *lisp_symbol_with_position_type; gcc_jit_type *lisp_symbol_with_position_ptr_type; gcc_jit_function *get_symbol_with_position; + gcc_jit_function *symbol_with_pos_sym; /* struct jmp_buf. */ gcc_jit_struct *jmp_buf_s; /* struct handler. */ @@ -1475,21 +1476,12 @@ emit_SYMBOL_WITH_POS_SYM (gcc_jit_rvalue *obj) { emit_comment ("SYMBOL_WITH_POS_SYM"); - gcc_jit_rvalue *tmp2, *swp; - gcc_jit_lvalue *tmpl; - - gcc_jit_rvalue *args[] = { obj }; - swp = gcc_jit_context_new_call (comp.ctxt, - NULL, - comp.get_symbol_with_position, - 1, - args); - tmpl = gcc_jit_rvalue_dereference (swp, gcc_jit_context_new_location (comp.ctxt, "comp.c", __LINE__, 0)); - tmp2 = gcc_jit_lvalue_as_rvalue (tmpl); - return - gcc_jit_rvalue_access_field (tmp2, - NULL, - comp.lisp_symbol_with_position_sym); + gcc_jit_rvalue *arg [] = { obj }; + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.symbol_with_pos_sym, + 1, + arg); } static gcc_jit_rvalue * @@ -1858,6 +1850,29 @@ emit_CHECK_CONS (gcc_jit_rvalue *x) args)); } +static void +emit_CHECK_SYMBOL_WITH_POS (gcc_jit_rvalue *x) +{ + emit_comment ("CHECK_SYMBOL_WITH_POS"); + + gcc_jit_rvalue *args[] = + { gcc_jit_context_new_cast (comp.ctxt, + NULL, + emit_SYMBOL_WITH_POS_P (x), + comp.int_type), + emit_lisp_obj_rval (Qsymbol_with_pos_p), + x }; + + gcc_jit_block_add_eval ( + comp.block, + NULL, + gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.check_type, + 3, + args)); +} + static gcc_jit_rvalue * emit_car_addr (gcc_jit_rvalue *c) { @@ -3886,6 +3901,48 @@ define_GET_SYMBOL_WITH_POSITION (void) 1, args, false)); } +static void define_SYMBOL_WITH_POS_SYM (void) +{ + gcc_jit_rvalue *tmpr, *swp; + gcc_jit_lvalue *tmpl; + + gcc_jit_param *param [] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "a") }; + comp.symbol_with_pos_sym = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.lisp_obj_type, + "SYMBOL_WITH_POS_SYM", + 1, + param, + 0); + + DECL_BLOCK (entry_block, comp.symbol_with_pos_sym); + comp.func = comp.symbol_with_pos_sym; + comp.block = entry_block; + + emit_CHECK_SYMBOL_WITH_POS (gcc_jit_param_as_rvalue (param [0])); + + gcc_jit_rvalue *args[] = { gcc_jit_param_as_rvalue (param [0]) }; + + swp = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.get_symbol_with_position, + 1, + args); + tmpl = gcc_jit_rvalue_dereference (swp, NULL); + tmpr = gcc_jit_lvalue_as_rvalue (tmpl); + gcc_jit_block_end_with_return (entry_block, + NULL, + gcc_jit_rvalue_access_field ( + tmpr, + NULL, + comp.lisp_symbol_with_position_sym)); +} + static void define_CHECK_IMPURE (void) { @@ -4504,6 +4561,7 @@ Return t on success. */) register_emitter (Qnumberp, emit_numperp); register_emitter (Qintegerp, emit_integerp); register_emitter (Qcomp_maybe_gc_or_quit, emit_maybe_gc_or_quit); + register_emitter (Qsymbol_with_pos_p, emit_SYMBOL_WITH_POS_P); } comp.ctxt = gcc_jit_context_acquire (); @@ -4820,6 +4878,7 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, define_PSEUDOVECTORP (); define_GET_SYMBOL_WITH_POSITION (); define_CHECK_TYPE (); + define_SYMBOL_WITH_POS_SYM (); define_CHECK_IMPURE (); define_bool_to_lisp_obj (); define_setcar_setcdr (); @@ -5618,6 +5677,7 @@ compiled one. */); DEFSYM (Qnumberp, "numberp"); DEFSYM (Qintegerp, "integerp"); DEFSYM (Qcomp_maybe_gc_or_quit, "comp-maybe-gc-or-quit"); + DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p"); /* Allocation classes. */ DEFSYM (Qd_default, "d-default"); diff --git a/src/data.c b/src/data.c index 1f2af6f4743..6d9c0aef933 100644 --- a/src/data.c +++ b/src/data.c @@ -3969,7 +3969,7 @@ A is a bool vector, B is t or nil, and I is an index into A. */) void syms_of_data (void) { - Lisp_Object error_tail, arith_tail; + Lisp_Object error_tail, arith_tail, recursion_tail; DEFSYM (Qquote, "quote"); DEFSYM (Qlambda, "lambda"); @@ -4004,6 +4004,10 @@ syms_of_data (void) DEFSYM (Qmark_inactive, "mark-inactive"); DEFSYM (Qinhibited_interaction, "inhibited-interaction"); + DEFSYM (Qrecursion_error, "recursion-error"); + DEFSYM (Qexcessive_variable_binding, "excessive-variable-binding"); + DEFSYM (Qexcessive_lisp_nesting, "excessive-lisp-nesting"); + DEFSYM (Qlistp, "listp"); DEFSYM (Qconsp, "consp"); DEFSYM (Qbare_symbol_p, "bare-symbol-p"); @@ -4112,6 +4116,16 @@ syms_of_data (void) PUT_ERROR (Qunderflow_error, Fcons (Qrange_error, arith_tail), "Arithmetic underflow error"); + recursion_tail = pure_cons (Qrecursion_error, error_tail); + Fput (Qrecursion_error, Qerror_conditions, recursion_tail); + Fput (Qrecursion_error, Qerror_message, build_pure_c_string + ("Excessive recursive calling error")); + + PUT_ERROR (Qexcessive_variable_binding, recursion_tail, + "Variable binding depth exceeds max-specpdl-size"); + PUT_ERROR (Qexcessive_lisp_nesting, recursion_tail, + "Lisp nesting exceeds `max-lisp-eval-depth'"); + /* Types that type-of returns. */ DEFSYM (Qinteger, "integer"); DEFSYM (Qsymbol, "symbol"); diff --git a/src/eval.c b/src/eval.c index 94ad0607732..5cb673ab223 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2398,8 +2398,7 @@ grow_specpdl (void) if (max_specpdl_size < 400) max_size = max_specpdl_size = 400; if (max_size <= specpdl_size) - signal_error ("Variable binding depth exceeds max-specpdl-size", - Qnil); + xsignal0 (Qexcessive_variable_binding); } pdlvec = xpalloc (pdlvec, &pdlvecsize, 1, max_size + 1, sizeof *specpdl); specpdl = pdlvec + 1; @@ -2453,7 +2452,7 @@ eval_sub (Lisp_Object form) if (max_lisp_eval_depth < 100) max_lisp_eval_depth = 100; if (lisp_eval_depth > max_lisp_eval_depth) - error ("Lisp nesting exceeds `max-lisp-eval-depth'"); + xsignal0 (Qexcessive_lisp_nesting); } Lisp_Object original_fun = XCAR (form); @@ -3044,7 +3043,7 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) if (max_lisp_eval_depth < 100) max_lisp_eval_depth = 100; if (lisp_eval_depth > max_lisp_eval_depth) - error ("Lisp nesting exceeds `max-lisp-eval-depth'"); + xsignal0 (Qexcessive_lisp_nesting); } count = record_in_backtrace (args[0], &args[1], nargs - 1); diff --git a/src/lread.c b/src/lread.c index 1cc5acc6d3a..835228439f1 100644 --- a/src/lread.c +++ b/src/lread.c @@ -3225,7 +3225,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list, bool locate_syms) build them using function calls. */ Lisp_Object tmp; struct Lisp_Vector *vec; - tmp = read_vector (readcharfun, 1, locate_syms); + tmp = read_vector (readcharfun, 1, false); vec = XVECTOR (tmp); if (! (COMPILED_STACK_DEPTH < ASIZE (tmp) && (FIXNUMP (AREF (tmp, COMPILED_ARGLIST)) -- cgit v1.2.3 From 57b698f15913385aec7bc9745016b961c0aa5c55 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Fri, 14 Jan 2022 19:06:04 +0000 Subject: Commit fixes and enhancements to the scratch/correct-warning-pos branch No longer strip positions from symbols before each use of a form, instead relying on the low level C routines to do the right thing. Instead strip them from miscellaneous places where this is needed. Stip them alson in `function-put'. Push forms onto byte-compile-form-stack and pop them "by hand" rather than by binding the variable at each pushing, so that it will still have its data after an error has been thrown and caught by a condition case. This gives an source position to the ensuing error message. * lisp/emacs-lisp/byte-run.el (byte-run--ssp-seen, byte-run--circular-list-p) (byte-run--strip-s-p-1, byte-run-strip-symbol-positions): New functions and variables, which together implement stripping of symbol positions. The latest (?final) version modifies the argument in place rather than making a copy. (function-put): Strip symbol positions from all of the arguments before doing the `put'. * lisp/emacs-lisp/bytecomp.el (byte-compile--form-stack): has been renamed to byte-compile-form-stack and moved to macroexp.el. (byte-compile-initial-macro-environment (eval-and-compile)): Replace macroexpand-all-toplevel with macroexpand--all-toplevel. (displaying-byte-compile-warnings): bind byte-compile-form-stack here. (byte-compile-toplevel-file-form, byte-compile-form): Push the top level form onto byte-compile-form-stack (whereas formally the variable was bound at each pushing). Manually pop this from of the variable at the end of the function. * lisp/emacs-lisp/cl-macs.el (cl-define-compiler-macro): Remove the symbol stripping. * lisp/emacs-lisp/comp.el (comp--native-compile): Set max-specpdl-size to at least 5000 (previously it was 2500). Bind print-symbols-bare to t. * lisp/emacs-lisp/macroexp.el (byte-compile-form-stack): Definition move here from bytecomp.el for easier compilation. (byte-compile-strip-symbol-positions and associated functions): Removed. (macro--expand-all): push argument FORM onto byte-compile-form-stack at the start of this function, and pop it off at the end. (internal-macroexpand-for-load): No longer strip symbol positions. Bind symbols-with-pos-enabled and print-symbols-bare to t. * lisp/help.el (help--make-usage): Strip any position from argument ARG. * src/fns.c (Fput): No longer strip symbol positions from any of the arguments. --- lisp/emacs-lisp/byte-run.el | 81 +++++++++- lisp/emacs-lisp/bytecomp.el | 116 ++++++-------- lisp/emacs-lisp/cl-macs.el | 5 +- lisp/emacs-lisp/comp.el | 4 +- lisp/emacs-lisp/macroexp.el | 380 +++++++++++++++++++------------------------- lisp/help.el | 2 +- src/fns.c | 5 - 7 files changed, 297 insertions(+), 296 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index f324bcd9714..fedc10cea44 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -30,6 +30,83 @@ ;;; Code: +(defvar byte-run--ssp-seen nil + "Which conses/vectors/records have been processed in strip-symbol-positions? +The value is a hash table, the key being the old element and the value being +the corresponding new element of the same type. + +The purpose of this is to detect circular structures.") + +(defalias 'byte-run--circular-list-p + #'(lambda (l) + "Return non-nil when the list L is a circular list. +Note that this algorithm doesn't check any circularity in the +CARs of list elements." + (let ((hare l) + (tortoise l)) + (condition-case err + (progn + (while (progn + (setq hare (cdr (cdr hare)) + tortoise (cdr tortoise)) + (not (or (eq tortoise hare) + (null hare))))) + (eq tortoise hare)) + (wrong-type-argument nil) + (error (signal (car err) (cdr err))))))) + +(defalias 'byte-run--strip-s-p-1 + #'(lambda (arg) + "Strip all positions from symbols in ARG, modifying ARG. +Return the modified ARG." + (cond + ((symbol-with-pos-p arg) + (bare-symbol arg)) + + ((consp arg) + (let* ((round (byte-run--circular-list-p arg)) + (hash (and round (gethash arg byte-run--ssp-seen)))) + (or hash + (let ((a arg) new) + (while + (progn + (when round + (puthash a new byte-run--ssp-seen)) + (setq new (byte-run--strip-s-p-1 (car a))) + (when (not (eq new (car a))) ; For read-only things. + (setcar a new)) + (and (consp (cdr a)) + (not + (setq hash + (and round + (gethash (cdr a) byte-run--ssp-seen)))))) + (setq a (cdr a))) + (setq new (byte-run--strip-s-p-1 (cdr a))) + (when (not (eq new (cdr a))) + (setcdr a (or hash new))) + arg)))) + + ((or (vectorp arg) (recordp arg)) + (let ((hash (gethash arg byte-run--ssp-seen))) + (or hash + (let* ((len (length arg)) + (i 0) + new) + (puthash arg arg byte-run--ssp-seen) + (while (< i len) + (setq new (byte-run--strip-s-p-1 (aref arg i))) + (when (not (eq new (aref arg i))) + (aset arg i new)) + (setq i (1+ i))) + arg)))) + + (t arg)))) + +(defalias 'byte-run-strip-symbol-positions + #'(lambda (arg) + (setq byte-run--ssp-seen (make-hash-table :test 'eq)) + (byte-run--strip-s-p-1 arg))) + (defalias 'function-put ;; We don't want people to just use `put' because we can't conveniently ;; hook into `put' to remap old properties to new ones. But for now, there's @@ -38,7 +115,9 @@ "Set FUNCTION's property PROP to VALUE. The namespace for PROP is shared with symbols. So far, FUNCTION can only be a symbol, not a lambda expression." - (put function prop value))) + (put (bare-symbol function) + (byte-run-strip-symbol-positions prop) + (byte-run-strip-symbol-positions value)))) (function-put 'defmacro 'doc-string-elt 3) (function-put 'defmacro 'lisp-indent-function 2) diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index b3197a97021..7ddca19626e 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -460,12 +460,6 @@ 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-recurse-toplevel (form non-toplevel-case) "Implement `eval-when-compile' and `eval-and-compile'. Return the compile-time value of FORM." @@ -506,9 +500,8 @@ Return the compile-time value of FORM." byte-compile-new-defuns)) (setf result (byte-compile-eval - (macroexp-strip-symbol-positions (byte-compile-top-level - (byte-compile-preprocess form)))))))) + (byte-compile-preprocess form))))))) (list 'quote result)))) (eval-and-compile . ,(lambda (&rest body) (byte-compile-recurse-toplevel @@ -517,10 +510,11 @@ 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 - (macroexpand--all-toplevel - form - macroexpand-all-environment))) + (let* ((print-symbols-bare t) + (expanded + (macroexpand--all-toplevel + form + macroexpand-all-environment))) (eval expanded lexical-binding) expanded))))) (with-suppressed-warnings @@ -1248,10 +1242,10 @@ Here, \"first\" is by a depth first search." (t 0)))) (defun byte-compile--warning-source-offset () - "Return a source offset from `byte-compile--form-stack'. + "Return a source offset from `byte-compile-form-stack'. Return nil if such is not found." (catch 'offset - (dolist (form byte-compile--form-stack) + (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))))))) @@ -1406,7 +1400,6 @@ 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 #'macroexp-strip-symbol-positions args)) (setq format (apply #'format-message format args)) (if byte-compile-error-on-warn (error "%s" format) ; byte-compile-file catches and logs it @@ -1417,7 +1410,7 @@ function directly; use `byte-compile-warn' or ARG is the source element (likely a symbol with position) central to the warning, intended to supply source position information. FORMAT and ARGS are as in `byte-compile-warn'." - (let ((byte-compile--form-stack (cons arg byte-compile--form-stack))) + (let ((byte-compile-form-stack (cons arg byte-compile-form-stack))) (apply #'byte-compile-warn format args))) (defun byte-compile-warn-obsolete (symbol) @@ -1867,7 +1860,8 @@ It is too wide if it has any lines longer than the largest of (warning-series-started (and (markerp warning-series) (eq (marker-buffer warning-series) - (get-buffer byte-compile-log-buffer))))) + (get-buffer byte-compile-log-buffer)))) + (byte-compile-form-stack byte-compile-form-stack)) (if (or (eq warning-series 'byte-compile-warning-series) warning-series-started) ;; warning-series does come from compilation, @@ -2257,10 +2251,7 @@ See also `emacs-lisp-byte-compile-and-load'." (write-region (point-min) (point-max) dynvar-file))))) (if load (load target-file)) - t))) - ;; Strip positions from symbols for the native compiler. - (setq byte-to-native-top-level-forms - (macroexp-strip-symbol-positions byte-to-native-top-level-forms)))) + t))))) ;;; compiling a single function ;;;###autoload @@ -2272,7 +2263,8 @@ With argument ARG, insert value in current buffer after the form." (save-excursion (end-of-defun) (beginning-of-defun) - (let* ((byte-compile-current-file (current-buffer)) + (let* ((print-symbols-bare t) + (byte-compile-current-file (current-buffer)) (byte-compile-current-buffer (current-buffer)) (byte-compile-read-position (point)) (byte-compile-last-position byte-compile-read-position) @@ -2319,7 +2311,7 @@ With argument ARG, insert value in current buffer after the form." (read-symbol-positions-list nil) ;; #### This is bound in b-c-close-variables. ;; (byte-compile-warnings byte-compile-warnings) - ) + (symbols-with-pos-enabled t)) (byte-compile-close-variables (with-current-buffer (setq byte-compile--outbuffer @@ -2432,11 +2424,10 @@ Call from the source buffer." ;; it here. (when byte-native-compiling ;; Spill output for the native compiler here - (push - (macroexp-strip-symbol-positions - (make-byte-to-native-top-level :form form :lexical lexical-binding)) - byte-to-native-top-level-forms)) - (let ((print-escape-newlines t) + (push (make-byte-to-native-top-level :form form :lexical lexical-binding) + byte-to-native-top-level-forms)) + (let ((print-symbols-bare t) + (print-escape-newlines t) (print-length nil) (print-level nil) (print-quoted t) @@ -2471,8 +2462,8 @@ list that represents a doc string reference. ;; in the input buffer (now current), not in the output buffer. (let ((dynamic-docstrings byte-compile-dynamic-docstrings)) (with-current-buffer byte-compile--outbuffer - (let (position) - + (let (position + (print-symbols-bare t)) ;; Insert the doc string, and make it a comment with #@LENGTH. (and (>= (nth 1 info) 0) dynamic-docstrings @@ -2596,13 +2587,16 @@ list that represents a doc string reference. ;; byte-hunk-handlers cannot call this! (defun byte-compile-toplevel-file-form (top-level-form) - (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))))))) + ;; (let ((byte-compile-form-stack + ;; (cons top-level-form byte-compile-form-stack))) + (push top-level-form byte-compile-form-stack) + (prog1 + (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))))) + (pop byte-compile-form-stack))) ;; byte-hunk-handlers can call this. (defun byte-compile-file-form (form) @@ -2635,8 +2629,7 @@ 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 (macroexp-strip-symbol-positions - (cons funsym (cons 'autoload (cdr (cdr form))))) + (push (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 @@ -2652,7 +2645,8 @@ list that represents a doc string reference. (delq (assq funsym byte-compile-unresolved-functions) byte-compile-unresolved-functions))))) (if (stringp (nth 3 form)) - (prog1 (macroexp-strip-symbol-positions form) + (prog1 + 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))) @@ -2692,8 +2686,7 @@ list that represents a doc string reference. (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) - (macroexp-strip-symbol-positions (nth 2 form))))) + (t (setcar (cddr form) (nth 2 form)))) (setcar form (bare-symbol (car form))) (if (symbolp (nth 1 form)) (setcar (cdr form) (bare-symbol (nth 1 form)))) @@ -2775,8 +2768,7 @@ list that represents a doc string reference. (defun byte-compile-file-form-make-obsolete (form) (prog1 (byte-compile-keep-pending form) (apply 'make-obsolete - (mapcar 'eval - (macroexp-strip-symbol-positions (cdr form)))))) + (mapcar 'eval (cdr form))))) (defun byte-compile-file-form-defmumble (name macro arglist body rest) "Process a `defalias' for NAME. @@ -2894,14 +2886,13 @@ not to take responsibility for the actual compilation of the code." (when byte-native-compiling ;; Spill output for the native compiler here. (push - (macroexp-strip-symbol-positions (if macro (make-byte-to-native-top-level :form `(defalias ',name '(macro . ,code) nil) :lexical lexical-binding) (make-byte-to-native-func-def :name name - :byte-func code))) - byte-to-native-top-level-forms)) + :byte-func code)) + byte-to-native-top-level-forms)) ;; Output the form by hand, that's much simpler than having ;; b-c-output-file-form analyze the defalias. (byte-compile-output-docform @@ -3020,9 +3011,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." (setq fun (eval fun t))) (if macro (push 'macro fun)) (if (symbolp form) (fset form fun)) - fun))) - (setq byte-to-native-top-level-forms - (macroexp-strip-symbol-positions byte-to-native-top-level-forms))))))) + fun)))))))) (defun byte-compile-sexp (sexp) "Compile and return SEXP." @@ -3169,8 +3158,7 @@ for symbols generated by the byte compiler itself." ;; which may include "calls" to ;; internal-make-closure (Bug#29988). lexical-binding) - (setq int (macroexp-strip-symbol-positions `(interactive ,newform))) - (setq int (macroexp-strip-symbol-positions int))))) + (setq int `(interactive ,newform))))) ((cdr int) ; Invalid (interactive . something). (byte-compile-warn-x int "malformed interactive spec: %s" int)))) @@ -3185,7 +3173,7 @@ for symbols generated by the byte compiler itself." (byte-compile-make-lambda-lexenv arglistvars)) reserved-csts)) - (bare-arglist (macroexp-strip-symbol-positions arglist))) + (bare-arglist arglist)) ;; Build the actual byte-coded function. (cl-assert (eq 'byte-code (car-safe compiled))) (let ((out @@ -3208,9 +3196,7 @@ 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) - (macroexp-strip-symbol-positions - command-modes)))) + (list (vector (nth 1 int) command-modes))) ;; No command modes, use the simple form with just the ;; interactive spec. (int @@ -3425,8 +3411,8 @@ 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) - (byte-compile--form-stack (cons form byte-compile--form-stack))) + (let ((byte-compile--for-effect for-effect)) + (push form byte-compile-form-stack) (cond ((not (consp form)) (cond ((or (not (symbolp form)) (macroexp--const-symbol-p form)) @@ -3500,7 +3486,8 @@ for symbols generated by the byte compiler itself." (setq byte-compile--for-effect nil)) ((byte-compile-normal-call form))) (if byte-compile--for-effect - (byte-compile-discard)))) + (byte-compile-discard)) + (pop byte-compile-form-stack))) (defun byte-compile-normal-call (form) (when (and (symbolp (car form)) @@ -3756,8 +3743,7 @@ assignment (i.e. `setq')." (setq const (bare-symbol const))) (byte-compile-out 'byte-constant - (byte-compile-get-constant - (macroexp-strip-symbol-positions const)))) + (byte-compile-get-constant const))) ;; Compile those primitive ordinary functions ;; which have special byte codes just for speed. @@ -4591,7 +4577,7 @@ Return (TAIL VAR TEST CASES), where: (dolist (case cases) (setq tag (byte-compile-make-tag) - test-objects (macroexp-strip-symbol-positions (car case)) + test-objects (car case) body (cdr case)) (byte-compile-out-tag tag) (dolist (value test-objects) @@ -5241,9 +5227,9 @@ OP and OPERAND are as passed to `byte-compile-out'." ;;; call tree stuff (defun byte-compile-annotate-call-tree (form) - (let ((current-form (macroexp-strip-symbol-positions + (let ((current-form (byte-run-strip-symbol-positions byte-compile-current-form)) - (bare-car-form (macroexp-strip-symbol-positions (car form))) + (bare-car-form (byte-run-strip-symbol-positions (car form))) entry) ;; annotate the current call (if (setq entry (assq bare-car-form byte-compile-call-tree)) @@ -5463,8 +5449,6 @@ already up-to-date." (if (null (batch-byte-compile-file (car command-line-args-left))) (setq error t)))) (setq command-line-args-left (cdr command-line-args-left))) - (setq byte-to-native-top-level-forms - (macroexp-strip-symbol-positions byte-to-native-top-level-forms)) (kill-emacs (if error 1 0)))) (defun batch-byte-compile-file (file) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index ecfa8801bf8..470168177ca 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3517,9 +3517,8 @@ and then returning foo." `(eval-and-compile ;; Name the compiler-macro function, so that `symbol-file' can find it. (cl-defun ,fname ,(if (memq '&whole args) (delq '&whole args) - (cons '_cl-whole-arg - (macroexp-strip-symbol-positions args))) - ,@(macroexp-strip-symbol-positions body)) + (cons '_cl-whole-arg args)) + ,@body) (put ',func 'compiler-macro #',fname)))) ;;;###autoload diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 225272f020e..dd5ad5a440b 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -4004,7 +4004,9 @@ the deferred compilation mechanism." (signal 'native-compiler-error (list "Not a function symbol or file" function-or-file))) (catch 'no-native-compile - (let* ((data function-or-file) + (let* ((print-symbols-bare t) + (max-specpdl-size (max max-specpdl-size 5000)) + (data function-or-file) (comp-native-compiling t) (byte-native-qualities nil) (symbols-with-pos-enabled t) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 663856a8fb3..faf0b1619e0 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -28,82 +28,21 @@ ;;; Code: +(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. + +Normally a form is manually pushed onto the list at the beginning +of `byte-compile-form', etc., and manually popped off at its end. +This is to preserve the data in it in the event of a +condition-case handling a signaled error.") + ;; Bound by the top-level `macroexpand-all', and modified to include any ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) -(defvar macroexp--ssp-conses-seen nil - "Which conses have been processed in a strip-symbol-positions operation?") -(defvar macroexp--ssp-vectors-seen nil - "Which vectors have been processed in a strip-symbol-positions operation?") -(defvar macroexp--ssp-records-seen nil - "Which records have been processed in a strip-symbol-positions operation?") - -(defun macroexp--strip-s-p-2 (arg) - "Strip all positions from symbols in ARG, destructively modifying ARG. -Return the modified ARG." - (cond - ((symbolp arg) - (bare-symbol arg)) - ((consp arg) - (unless (and macroexp--ssp-conses-seen - (gethash arg macroexp--ssp-conses-seen)) - (if macroexp--ssp-conses-seen - (puthash arg t macroexp--ssp-conses-seen)) - (let ((a arg)) - (while (consp (cdr a)) - (setcar a (macroexp--strip-s-p-2 (car a))) - (setq a (cdr a))) - (setcar a (macroexp--strip-s-p-2 (car a))) - ;; (if (cdr a) - (unless (bare-symbol-p (cdr a)) ; includes (unpositioned) nil. - (setcdr a (macroexp--strip-s-p-2 (cdr a)))))) - arg) - ((vectorp arg) - (unless (and macroexp--ssp-vectors-seen - (gethash arg macroexp--ssp-vectors-seen)) - (if macroexp--ssp-vectors-seen - (puthash arg t macroexp--ssp-vectors-seen)) - (let ((i 0) - (len (length arg))) - (while (< i len) - (aset arg i (macroexp--strip-s-p-2 (aref arg i))) - (setq i (1+ i))))) - arg) - ((recordp arg) - (unless (and macroexp--ssp-records-seen - (gethash arg macroexp--ssp-records-seen)) - (if macroexp--ssp-records-seen - (puthash arg t macroexp--ssp-records-seen)) - (let ((i 0) - (len (length arg))) - (while (< i len) - (aset arg i (macroexp--strip-s-p-2 (aref arg i))) - (setq i (1+ i))))) - arg) - (t arg))) - -(defun byte-compile-strip-s-p-1 (arg) - "Strip all positions from symbols in ARG, destructively modifying ARG. -Return the modified ARG." - (condition-case err - (progn - (setq macroexp--ssp-conses-seen nil) - (setq macroexp--ssp-vectors-seen nil) - (setq macroexp--ssp-records-seen nil) - (macroexp--strip-s-p-2 arg)) - (recursion-error - (dolist (tab '(macroexp--ssp-conses-seen macroexp--ssp-vectors-seen - macroexp--ssp-records-seen)) - (set tab (make-hash-table :test 'eq))) - (macroexp--strip-s-p-2 arg)) - (error (signal (car err) (cdr err))))) - -(defun macroexp-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 macroexp--cons (car cdr original-cons) "Return ORIGINAL-CONS if the car/cdr of it is `eq' to CAR and CDR, respectively. If not, return (CAR . CDR)." @@ -378,120 +317,122 @@ Only valid during macro-expansion." "Expand all macros in FORM. This is an internal version of `macroexpand-all'. Assumes the caller has bound `macroexpand-all-environment'." - (if (eq (car-safe form) 'backquote-list*) - ;; Special-case `backquote-list*', as it is normally a macro that - ;; generates exceedingly deep expansions from relatively shallow input - ;; forms. We just process it `in reverse' -- first we expand all the - ;; arguments, _then_ we expand the top-level definition. - (macroexpand (macroexp--all-forms form 1) - macroexpand-all-environment) - ;; Normal form; get its expansion, and then expand arguments. - (setq form (macroexp-macroexpand form macroexpand-all-environment)) - ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when - ;; I tried it, it broke the bootstrap :-( - (pcase form - (`(cond . ,clauses) - (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) - (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) - (macroexp--cons - 'condition-case - (macroexp--cons err - (macroexp--cons (macroexp--expand-all body) - (macroexp--all-clauses handlers 1) - (cddr form)) - (cdr form)) - form)) - (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) - (push name macroexp--dynvars) - (macroexp--all-forms form 2)) - (`(function ,(and f `(lambda . ,_))) - (let ((macroexp--dynvars macroexp--dynvars)) - (macroexp--cons 'function - (macroexp--cons (macroexp--all-forms f 2) - nil - (cdr form)) - form))) - (`(,(or 'function 'quote) . ,_) form) - (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) - pcase--dontcare)) - (let ((macroexp--dynvars macroexp--dynvars)) - (macroexp--cons - fun - (macroexp--cons - (macroexp--all-clauses bindings 1) - (if (null body) - (macroexp-unprogn - (macroexp-warn-and-return - fun - (format "Empty %s body" fun) - nil nil 'compile-only)) - (macroexp--all-forms body)) - (cdr form)) - form))) - (`(,(and fun `(lambda . ,_)) . ,args) - ;; Embedded lambda in function position. - ;; If the byte-optimizer is loaded, try to unfold this, - ;; i.e. rewrite it to (let () ). We'd do it in the optimizer - ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the - ;; creation of a closure, thus resulting in much better code. - (let ((newform (macroexp--unfold-lambda form))) - (if (eq newform form) - ;; Unfolding failed for some reason, avoid infinite recursion. - (macroexp--cons (macroexp--all-forms fun 2) - (macroexp--all-forms args) - form) - (macroexp--expand-all newform)))) - - (`(funcall . ,(or `(,exp . ,args) pcase--dontcare)) - (let ((eexp (macroexp--expand-all exp)) - (eargs (macroexp--all-forms args))) - ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' - ;; has a compiler-macro, or to unfold it. - (pcase eexp - (`#',f (macroexp--expand-all `(,f . ,eargs))) - (_ `(funcall ,eexp . ,eargs))))) - (`(,func . ,_) - (let ((handler (function-get func 'compiler-macro)) - (funargs (function-get func 'funarg-positions))) - ;; Check functions quoted with ' rather than with #' - (dolist (funarg funargs) - (let ((arg (nth funarg form))) - (when (and (eq 'quote (car-safe arg)) - (eq 'lambda (car-safe (cadr arg)))) - (setcar (nthcdr funarg form) - (macroexp-warn-and-return - (cadr arg) - (format "%S quoted with ' rather than with #'" - (let ((f (cadr arg))) - (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) - arg))))) - ;; Macro expand compiler macros. This cannot be delayed to - ;; byte-optimize-form because the output of the compiler-macro can - ;; use macros. - (if (null handler) - ;; No compiler macro. We just expand each argument (for - ;; setq/setq-default this works alright because the variable names - ;; are symbols). - (macroexp--all-forms form 1) - ;; If the handler is not loaded yet, try (auto)loading the - ;; function itself, which may in turn load the handler. - (unless (functionp handler) - (with-demoted-errors "macroexp--expand-all: %S" - (autoload-do-load (indirect-function func) func))) - (let ((newform (macroexp--compiler-macro handler form))) - (if (eq form newform) - ;; The compiler macro did not find anything to do. - (if (equal form (setq newform (macroexp--all-forms form 1))) - form - ;; Maybe after processing the args, some new opportunities - ;; appeared, so let's try the compiler macro again. - (setq form (macroexp--compiler-macro handler newform)) - (if (eq newform form) - newform - (macroexp--expand-all newform))) - (macroexp--expand-all newform)))))) - - (_ form)))) + (push form byte-compile-form-stack) + (prog1 + (if (eq (car-safe form) 'backquote-list*) + ;; Special-case `backquote-list*', as it is normally a macro that + ;; generates exceedingly deep expansions from relatively shallow input + ;; forms. We just process it `in reverse' -- first we expand all the + ;; arguments, _then_ we expand the top-level definition. + (macroexpand (macroexp--all-forms form 1) + macroexpand-all-environment) + ;; Normal form; get its expansion, and then expand arguments. + (setq form (macroexp-macroexpand form macroexpand-all-environment)) + ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when + ;; I tried it, it broke the bootstrap :-( + (pcase form + (`(cond . ,clauses) + (macroexp--cons 'cond (macroexp--all-clauses clauses) form)) + (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) + (macroexp--cons + 'condition-case + (macroexp--cons err + (macroexp--cons (macroexp--expand-all body) + (macroexp--all-clauses handlers 1) + (cddr form)) + (cdr form)) + form)) + (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) + (push name macroexp--dynvars) + (macroexp--all-forms form 2)) + (`(function ,(and f `(lambda . ,_))) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons 'function + (macroexp--cons (macroexp--all-forms f 2) + nil + (cdr form)) + form))) + (`(,(or 'function 'quote) . ,_) form) + (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) + pcase--dontcare)) + (let ((macroexp--dynvars macroexp--dynvars)) + (macroexp--cons + fun + (macroexp--cons + (macroexp--all-clauses bindings 1) + (if (null body) + (macroexp-unprogn + (macroexp-warn-and-return + fun + (format "Empty %s body" fun) + nil nil 'compile-only)) + (macroexp--all-forms body)) + (cdr form)) + form))) + (`(,(and fun `(lambda . ,_)) . ,args) + ;; Embedded lambda in function position. + ;; If the byte-optimizer is loaded, try to unfold this, + ;; i.e. rewrite it to (let () ). We'd do it in the optimizer + ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the + ;; creation of a closure, thus resulting in much better code. + (let ((newform (macroexp--unfold-lambda form))) + (if (eq newform form) + ;; Unfolding failed for some reason, avoid infinite recursion. + (macroexp--cons (macroexp--all-forms fun 2) + (macroexp--all-forms args) + form) + (macroexp--expand-all newform)))) + (`(funcall . ,(or `(,exp . ,args) pcase--dontcare)) + (let ((eexp (macroexp--expand-all exp)) + (eargs (macroexp--all-forms args))) + ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' + ;; has a compiler-macro, or to unfold it. + (pcase eexp + (`#',f (macroexp--expand-all `(,f . ,eargs))) + (_ `(funcall ,eexp . ,eargs))))) + (`(,func . ,_) + (let ((handler (function-get func 'compiler-macro)) + (funargs (function-get func 'funarg-positions))) + ;; Check functions quoted with ' rather than with #' + (dolist (funarg funargs) + (let ((arg (nth funarg form))) + (when (and (eq 'quote (car-safe arg)) + (eq 'lambda (car-safe (cadr arg)))) + (setcar (nthcdr funarg form) + (macroexp-warn-and-return + (cadr arg) + (format "%S quoted with ' rather than with #'" + (let ((f (cadr arg))) + (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) + arg))))) + ;; Macro expand compiler macros. This cannot be delayed to + ;; byte-optimize-form because the output of the compiler-macro can + ;; use macros. + (if (null handler) + ;; No compiler macro. We just expand each argument (for + ;; setq/setq-default this works alright because the variable names + ;; are symbols). + (macroexp--all-forms form 1) + ;; If the handler is not loaded yet, try (auto)loading the + ;; function itself, which may in turn load the handler. + (unless (functionp handler) + (with-demoted-errors "macroexp--expand-all: %S" + (autoload-do-load (indirect-function func) func))) + (let ((newform (macroexp--compiler-macro handler form))) + (if (eq form newform) + ;; The compiler macro did not find anything to do. + (if (equal form (setq newform (macroexp--all-forms form 1))) + form + ;; Maybe after processing the args, some new opportunities + ;; appeared, so let's try the compiler macro again. + (setq form (macroexp--compiler-macro handler newform)) + (if (eq newform form) + newform + (macroexp--expand-all newform))) + (macroexp--expand-all newform)))))) + + (_ form))) + (pop byte-compile-form-stack))) ;; Record which arguments expect functions, so we can warn when those ;; are accidentally quoted with ' rather than with #' @@ -781,39 +722,40 @@ test of free variables in the following ways: (defun internal-macroexpand-for-load (form full-p) ;; Called from the eager-macroexpansion in readevalloop. - (setq form (macroexp-strip-symbol-positions form)) - (cond - ;; Don't repeat the same warning for every top-level element. - ((eq 'skip (car macroexp--pending-eager-loads)) form) - ;; If we detect a cycle, skip macro-expansion for now, and output a warning - ;; with a trimmed backtrace. - ((and load-file-name (member load-file-name macroexp--pending-eager-loads)) - (let* ((bt (delq nil - (mapcar #'macroexp--trim-backtrace-frame - (macroexp--backtrace)))) - (elem `(load ,(file-name-nondirectory load-file-name))) - (tail (member elem (cdr (member elem bt))))) - (if tail (setcdr tail (list '…))) - (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) - (if macroexp--debug-eager - (debug 'eager-macroexp-cycle) - (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" - (mapconcat #'prin1-to-string (nreverse bt) " => "))) - (push 'skip macroexp--pending-eager-loads) - form)) - (t - (condition-case err - (let ((macroexp--pending-eager-loads - (cons load-file-name macroexp--pending-eager-loads))) - (if full-p - (macroexpand--all-toplevel form) - (macroexpand form))) - (error - ;; Hopefully this shouldn't happen thanks to the cycle detection, - ;; but in case it does happen, let's catch the error and give the - ;; code a chance to macro-expand later. - (message "Eager macro-expansion failure: %S" err) - form))))) + (let ((symbols-with-pos-enabled t) + (print-symbols-bare t)) + (cond + ;; Don't repeat the same warning for every top-level element. + ((eq 'skip (car macroexp--pending-eager-loads)) form) + ;; If we detect a cycle, skip macro-expansion for now, and output a warning + ;; with a trimmed backtrace. + ((and load-file-name (member load-file-name macroexp--pending-eager-loads)) + (let* ((bt (delq nil + (mapcar #'macroexp--trim-backtrace-frame + (macroexp--backtrace)))) + (elem `(load ,(file-name-nondirectory load-file-name))) + (tail (member elem (cdr (member elem bt))))) + (if tail (setcdr tail (list '…))) + (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) + (if macroexp--debug-eager + (debug 'eager-macroexp-cycle) + (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" + (mapconcat #'prin1-to-string (nreverse bt) " => "))) + (push 'skip macroexp--pending-eager-loads) + form)) + (t + (condition-case err + (let ((macroexp--pending-eager-loads + (cons load-file-name macroexp--pending-eager-loads))) + (if full-p + (macroexpand--all-toplevel form) + (macroexpand form))) + (error + ;; Hopefully this shouldn't happen thanks to the cycle detection, + ;; but in case it does happen, let's catch the error and give the + ;; code a chance to macro-expand later. + (message "Eager macro-expansion failure: %S" err) + form)))))) ;; ¡¡¡ Big Ugly Hack !!! ;; src/bootstrap-emacs is mostly used to compile .el files, so it needs diff --git a/lisp/help.el b/lisp/help.el index b142cce845c..983f39479cb 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -2069,7 +2069,7 @@ the same names as used in the original source code, when possible." ((symbolp arg) (let ((name (symbol-name arg))) (cond - ((string-match "\\`&" name) arg) + ((string-match "\\`&" name) (bare-symbol arg)) ((string-match "\\`_." name) (intern (upcase (substring name 1)))) (t (intern (upcase name)))))) diff --git a/src/fns.c b/src/fns.c index 9f39d56dd33..ade30fca41f 100644 --- a/src/fns.c +++ b/src/fns.c @@ -2414,11 +2414,6 @@ It can be retrieved with `(get SYMBOL PROPNAME)'. */) (Lisp_Object symbol, Lisp_Object propname, Lisp_Object value) { CHECK_SYMBOL (symbol); - if (symbols_with_pos_enabled) - { - propname = call1 (intern ("macroexp-strip-symbol-positions"), propname); - value = call1 (intern ("macroexp-strip-symbol-positions"), value); - } set_symbol_plist (symbol, Fplist_put (XSYMBOL (symbol)->u.s.plist, propname, value)); return value; -- cgit v1.2.3 From 3023e7ca3d911d431738551753e4cfb8e3e01ec5 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Sat, 15 Jan 2022 17:36:12 +0000 Subject: Remove the remnants of old position mechanism from scratch/correct-warning-pos Also correct one or two positions in macroexp-warn-and-return invocations. * lisp/emacs-lisp/bytecomp.el (byte-compile-read-position) (byte-compile-last-position, byte-compile-set-symbol-position): Remove. (byte-compile-warning-prefix, byte-compile-function-warn) (byte-compile-emit-callargs-warn, byte-compile-arglist-warn) (byte-compile-warn-about-unresolved-functions, compile-defun) (byte-compile-from-buffer, byte-compile-from-buffer) (byte-compile-file-form-defmumble, byte-compile-check-lambda-list) (byte-compile-lambda, byte-compile-form, byte-compile-normal-call) (byte-compile-check-variable, byte-compile-push-constant) (byte-compile-subr-wrong-args, byte-compile-negation-optimizer) (byte-compile-condition-case, byte-compile-defvar, byte-compile-autoload) (byte-compile-lambda-form): Remove the remnants of the old warning position mechanism. (byte-compile-function-warn): Replace byte-compile-last-position by a symbol-with-pos-pos call. (compile-defun): Use local variable start-read-position to fulfil purpose of old byte-compile-read-position. Push the just read FORM onto byte-compile-form-stack. * lisp/emacs-lisp/eieio.el (defclass): New mechanism to get the correct source warning position to macroexp-warn-and-return. * lisp/emacs-lisp/macroexp (macroexp--unfold-lambda): Correct the position argument given to macroexp-warn-and-return. --- lisp/emacs-lisp/bytecomp.el | 136 +++++++------------------------------------- lisp/emacs-lisp/eieio.el | 17 +++--- lisp/emacs-lisp/macroexp.el | 4 +- 3 files changed, 34 insertions(+), 123 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 7ddca19626e..41d2126dbcf 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1149,11 +1149,6 @@ message buffer `default-directory'." (t (insert (format "%s\n" string))))))) -(defvar byte-compile-read-position nil - "Character position we began the last `read' from.") -(defvar byte-compile-last-position nil - "Last known character position in the input.") - ;; copied from gnus-util.el (defsubst byte-compile-delete-first (elt list) (if (eq (car list) elt) @@ -1166,43 +1161,6 @@ message buffer `default-directory'." (setcdr list (cddr list))) total))) -;; The purpose of `byte-compile-set-symbol-position' is to attempt to -;; set `byte-compile-last-position' to the "current position" in the -;; raw source code. This is used for warning and error messages. -;; -;; The function should be called for most occurrences of symbols in -;; the forms being compiled, strictly in the order they occur in the -;; source code. It should never be called twice for any single -;; occurrence, and should not be called for symbols generated by the -;; byte compiler itself. -;; -;; The function works by scanning the elements in the alist -;; `read-symbol-positions-list' for the next match for the symbol -;; after the current value of `byte-compile-last-position', setting -;; that variable to the match's character position, then deleting the -;; matching element from the list. Thus the new value for -;; `byte-compile-last-position' is later than the old value unless, -;; perhaps, ALLOW-PREVIOUS is non-nil. -;; -;; So your're probably asking yourself: Isn't this function a gross -;; hack? And the answer, of course, would be yes. -(defun byte-compile-set-symbol-position (sym &optional allow-previous) - (when byte-compile-read-position - (let ((last byte-compile-last-position) - entry) - (while (progn - (setq entry (assq sym read-symbol-positions-list)) - (when entry - (setq byte-compile-last-position - (+ byte-compile-read-position (cdr entry)) - read-symbol-positions-list - (byte-compile-delete-first - entry read-symbol-positions-list))) - (and entry - (or (and allow-previous - (not (= last byte-compile-last-position))) - (> last byte-compile-last-position)))))))) - (defvar byte-compile-last-warned-form nil) (defvar byte-compile-last-logged-file nil) (defvar byte-compile-root-dir nil @@ -1269,34 +1227,14 @@ Return nil if such is not found." (t ""))) (offset (byte-compile--warning-source-offset)) (pos (if (and byte-compile-current-file - (integerp byte-compile-read-position) (or offset (not symbols-with-pos-enabled))) (with-current-buffer byte-compile-current-buffer - ;; (format "%d:%d:" - ;; (save-excursion - ;; (goto-char (if symbols-with-pos-enabled - ;; (+ byte-compile-read-position offset) - ;; byte-compile-last-position) - ;; ) - ;; (1+ (count-lines (point-min) (point-at-bol)))) - ;; (save-excursion - ;; (goto-char (if symbols-with-pos-enabled - ;; (+ byte-compile-read-position offset) - ;; byte-compile-last-position) - ;; ) - ;; (1+ (current-column)))) -;;;; EXPERIMENTAL STOUGH, 2018-11-22 - (let (old-l old-c new-l new-c) + (let (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 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 - ) + (format "%d:%d:" new-l new-c)))) "")) (form (if (eq byte-compile-current-form :end) "end of data" (or byte-compile-current-form "toplevel form")))) @@ -1379,7 +1317,7 @@ nil.") STRING, FILL and LEVEL are as described in `byte-compile-log-warning-function', which see." (funcall byte-compile-log-warning-function - string byte-compile-last-position + string nil fill level)) @@ -1525,7 +1463,6 @@ when printing the error message." (t (format "%d-%d" (car signature) (cdr signature))))) (defun byte-compile-function-warn (f nargs def) - (byte-compile-set-symbol-position f) (when (and (get f 'byte-obsolete-info) (byte-compile-warning-enabled-p 'obsolete f)) (byte-compile-warn-obsolete f)) @@ -1542,11 +1479,14 @@ when printing the error message." (if cons (or (memq nargs (cddr cons)) (push nargs (cddr cons))) - (push (list f byte-compile-last-position nargs) + (push (list f + (if (symbol-with-pos-p f) + (symbol-with-pos-pos f) + 1) ; Should never happen. + nargs) byte-compile-unresolved-functions))))) (defun byte-compile-emit-callargs-warn (name actual-args min-args max-args) - (byte-compile-set-symbol-position name) (byte-compile-warn-x name "%s called with %d argument%s, but %s %s" @@ -1672,7 +1612,6 @@ extra args." max (car (nreverse nums))) (when (or (< min (car sig)) (and (cdr sig) (> max (cdr sig)))) - (byte-compile-set-symbol-position name) (byte-compile-warn-x name "%s being defined to take %s%s, but was previously called with %s" @@ -1692,7 +1631,6 @@ extra args." (let ((sig1 (byte-compile--function-signature old)) (sig2 (byte-compile-arglist-signature arglist))) (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) - (byte-compile-set-symbol-position name) (byte-compile-warn-x name "%s %s used to take %s %s, now takes %s" @@ -1785,7 +1723,7 @@ It is too wide if it has any lines longer than the largest of (byte-compile--wide-docstring-p docs col)) (byte-compile-warn-x name - "%s%s docstring wider than %s characters" + "%s%sdocstring wider than %s characters" kind name col)))) form) @@ -1800,11 +1738,10 @@ It is too wide if it has any lines longer than the largest of (dolist (urf byte-compile-unresolved-functions) (let ((f (car urf))) (when (not (memq f byte-compile-new-defuns)) - (let ((byte-compile-last-position (cadr urf))) - (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)))))))) + (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) @@ -2266,8 +2203,7 @@ With argument ARG, insert value in current buffer after the form." (let* ((print-symbols-bare t) (byte-compile-current-file (current-buffer)) (byte-compile-current-buffer (current-buffer)) - (byte-compile-read-position (point)) - (byte-compile-last-position byte-compile-read-position) + (start-read-position (point)) (byte-compile-last-warned-form 'nothing) (value (eval (let ((read-with-symbol-positions (current-buffer)) @@ -2275,9 +2211,11 @@ With argument ARG, insert value in current buffer after the form." (symbols-with-pos-enabled t)) (displaying-byte-compile-warnings (byte-compile-sexp - (eval-sexp-add-defvars - (read-positioning-symbols (current-buffer)) - byte-compile-read-position)))) + (let ((form (read-positioning-symbols (current-buffer)))) + (push form byte-compile-form-stack) + (eval-sexp-add-defvars + form + start-read-position))))) lexical-binding))) (cond (arg (message "Compiling from buffer... done.") @@ -2287,8 +2225,6 @@ With argument ARG, insert value in current buffer after the form." (defun byte-compile-from-buffer (inbuffer) (let ((byte-compile-current-buffer inbuffer) - (byte-compile-read-position nil) - (byte-compile-last-position nil) ;; Prevent truncation of flonums and lists as we read and print them (float-output-format nil) (case-fold-search nil) @@ -2357,8 +2293,6 @@ With argument ARG, insert value in current buffer after the form." (= (following-char) ?\;)) (forward-line 1)) (not (eobp))) - (setq byte-compile-read-position (point) - byte-compile-last-position byte-compile-read-position) (let* ((lread--unescaped-character-literals nil) (form (read-positioning-symbols inbuffer)) (warning (byte-run--unescaped-character-literals-warning))) @@ -2366,9 +2300,6 @@ With argument ARG, insert value in current buffer after the form." (byte-compile-toplevel-file-form form))) ;; Compile pending forms at end of file. (byte-compile-flush-pending) - ;; Make warnings about unresolved functions - ;; give the end of the file as their position. - (setq byte-compile-last-position (point-max)) (byte-compile-warn-about-unresolved-functions))) byte-compile--outbuffer))) @@ -2786,7 +2717,6 @@ not to take responsibility for the actual compilation of the code." (bare-name (bare-symbol name)) (byte-compile-current-form name)) ; For warnings. - (byte-compile-set-symbol-position name) (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. @@ -2845,8 +2775,6 @@ not to take responsibility for the actual compilation of the code." (symbolp (car-safe (cdr-safe body))) (car-safe (cdr-safe body)) (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-x name "probable `\"' without `\\' in doc string of %s" bare-name)) @@ -3024,8 +2952,6 @@ If FORM is a lambda or a macro, byte-compile it as a function." (let (vars) (while list (let ((arg (car list))) - (when (symbolp arg) - (byte-compile-set-symbol-position arg)) (cond ((or (not (symbolp arg)) (macroexp--const-symbol-p arg t)) (error "Invalid lambda variable %s" arg)) @@ -3099,16 +3025,11 @@ If FORM is a lambda or a macro, byte-compile it as a function." (defun byte-compile-lambda (fun &optional add-lambda reserved-csts) "Byte-compile a lambda-expression and return a valid function. The value is usually a compiled function but may be the original -lambda-expression. -When ADD-LAMBDA is non-nil, the symbol `lambda' is added as head -of the list FUN and `byte-compile-set-symbol-position' is not called. -Use this feature to avoid calling `byte-compile-set-symbol-position' -for symbols generated by the byte compiler itself." +lambda-expression." (if add-lambda (setq fun (cons 'lambda fun)) (unless (eq 'lambda (car-safe fun)) - (error "Not a lambda list: %S" fun)) - (byte-compile-set-symbol-position 'lambda)) + (error "Not a lambda list: %S" fun))) (byte-compile-docstring-length-warn fun) (byte-compile-check-lambda-list (nth 1 fun)) (let* ((arglist (nth 1 fun)) @@ -3131,7 +3052,6 @@ for symbols generated by the byte compiler itself." (byte-compile--warn-lexical-dynamic var 'lambda)))) ;; Process the interactive spec. (when int - (byte-compile-set-symbol-position 'interactive) ;; Skip (interactive) if it is in front (the most usual location). (if (eq int (car body)) (setq body (cdr body))) @@ -3416,13 +3336,9 @@ for symbols generated by the byte compiler itself." (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 (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 (bare-symbol form))))) @@ -3501,7 +3417,6 @@ for symbols generated by the byte compiler itself." (byte-compile-annotate-call-tree form)) (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-x (car form) "`mapcar' called for effect; use `mapc' or `dolist' instead")) @@ -3634,8 +3549,6 @@ for symbols generated by the byte compiler itself." (defun byte-compile-check-variable (var access-type) "Do various error checks before a use of the variable VAR." - (when (symbolp var) - (byte-compile-set-symbol-position var)) (cond ((or (not (symbolp var)) (macroexp--const-symbol-p var)) (when (byte-compile-warning-enabled-p 'constants (and (symbolp var) var)) @@ -3739,7 +3652,6 @@ assignment (i.e. `setq')." ;; This ignores byte-compile--for-effect. (defun byte-compile-push-constant (const) (when (symbolp const) - (byte-compile-set-symbol-position const) (setq const (bare-symbol const))) (byte-compile-out 'byte-constant @@ -3895,7 +3807,6 @@ 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-x (car form) "`%s' called with %d arg%s, but requires %s" (car form) (length (cdr form)) @@ -4831,7 +4742,6 @@ binding slots have been popped." ;; Even when optimization is off, /= is optimized to (not (= ...)). (defun byte-compile-negation-optimizer (form) ;; an optimizer for forms where is less efficient than (not ) - (byte-compile-set-symbol-position (car form)) (list 'not (cons (or (get (car form) 'byte-compile-negated-op) (error @@ -4881,7 +4791,6 @@ binding slots have been popped." (cons (byte-compile-make-tag) clause)) failure-handlers)) (endtag (byte-compile-make-tag))) - (byte-compile-set-symbol-position 'condition-case) (unless (symbolp var) (byte-compile-warn-x var "`%s' is not a variable-name or nil (in condition-case)" var)) @@ -4994,7 +4903,6 @@ binding slots have been popped." (var (nth 1 form)) (value (nth 2 form)) (string (nth 3 form))) - (byte-compile-set-symbol-position fun) (when (or (> (length form) 4) (and (eq fun 'defconst) (null (cddr form)))) (let ((ncall (length (cdr form)))) @@ -5027,7 +4935,6 @@ binding slots have been popped." `',var))))) (defun byte-compile-autoload (form) - (byte-compile-set-symbol-position 'autoload) (and (macroexp-const-p (nth 1 form)) (macroexp-const-p (nth 5 form)) (memq (eval (nth 5 form)) '(t macro)) ; macro-p @@ -5042,7 +4949,6 @@ binding slots have been popped." ;; Lambdas in valid places are handled as special cases by various code. ;; The ones that remain are errors. (defun byte-compile-lambda-form (_form) - (byte-compile-set-symbol-position 'lambda) (error "`lambda' used as function name is invalid")) ;; Compile normally, but deal with warnings for the function being defined. diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index e6a5685b5ed..820e8383d86 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -181,9 +181,11 @@ and reference them using the function `class-option'." ;; Is there an initarg, but allocation of class? (when (and initarg (eq alloc :class)) - (push (format "Meaningless :initarg for class allocated slot '%S'" - sname) - warnings)) + (push + (cons sname + (format "Meaningless :initarg for class allocated slot '%S'" + sname)) + warnings)) (let ((init (plist-get soptions :initform))) (unless (or (macroexp-const-p init) @@ -194,8 +196,9 @@ and reference them using the function `class-option'." ;; heuristic says and if it disagrees with normal evaluation ;; then tweak the initform to make it fit and emit ;; a warning accordingly. - (push (format "Ambiguous initform needs quoting: %S" init) - warnings))) + (push + (cons init (format "Ambiguous initform needs quoting: %S" init)) + warnings))) ;; Anyone can have an accessor function. This creates a function ;; of the specified name, and also performs a `defsetf' if applicable @@ -242,8 +245,8 @@ This method is obsolete." `(progn ,@(mapcar (lambda (w) - (macroexp-warn-and-return w ; W is probably a poor choice for a position. - w `(progn ',w) nil 'compile-only)) + (macroexp-warn-and-return + (car w) (cdr w) `(progn ',(cdr w)) nil 'compile-only)) warnings) ;; This test must be created right away so we can have self- ;; referencing classes. ei, a class whose slot can contain only diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 27a7a8f8cf1..256092599b2 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -162,6 +162,8 @@ Other uses risk returning non-nil value that point to the wrong file." #'macroexp-warn-and-return "28.1") (defun macroexp-warn-and-return (arg msg form &optional category compile-only) "Return code equivalent to FORM labeled with warning MSG. +ARG is a symbol (or a form) giving the source code position of FORM +for the message. It should normally be a symbol with position. CATEGORY is the category of the warning, like the categories that can appear in `byte-compile-warnings'. COMPILE-ONLY non-nil means no warning should be emitted if the code @@ -287,7 +289,7 @@ is executed without being compiled first." (setq arglist (cdr arglist))) (if values (macroexp-warn-and-return - name + arglist (format (if (eq values 'too-few) "attempt to open-code `%s' with too few arguments" "attempt to open-code `%s' with too many arguments") -- cgit v1.2.3 From bdd9b5b8a0d37dd09ee530c1dab3a44bee09e0f8 Mon Sep 17 00:00:00 2001 From: Alan Mackenzie Date: Sat, 22 Jan 2022 09:59:05 +0000 Subject: Miscellaneous amendments to the scratch/correct-warning-pos branch * lisp/cedet/semantic/fw.el (semantic-alias-obsolete) (semantic-varalias-obsolete): Replace calls to byte-compile-warn with calls to byte-compile-warn-x (when it exists). * lisp/emacs-lisp/bytecomp.el (byte-compile-log-warning-function) (byte-compile--log-warning-for-byte-compile): Make the POSITION parameter no longer &optional (for the benefit of flymake on *.el). (byte-compile-log-warning): Replace a nil POSITION argument with an actual position. (byte-compile-file-form-require): Push the required symbol onto byte-compile-form-stack, for the benefit of `do-after-load-evaluation'. * lisp/keymap.el (define-keymap--compile): Replace four calls to byte-compile-warn with byte-compile-warn-x. * doc/lispref/elisp.texi (master menu): Add entries for Shorthands and Symbols with position. * doc/lispref/streams.texi (Input Functions): Document read-positioning-symbols. * doc/lispref/symbols.texi (Symbols): Add new menu entry. (Symbols with Position): New @section. --- doc/lispref/elisp.texi | 3 ++ doc/lispref/streams.texi | 10 ++++++ doc/lispref/symbols.texi | 82 ++++++++++++++++++++++++++++++++++++++++----- lisp/cedet/semantic/fw.el | 32 ++++++++++++------ lisp/emacs-lisp/bytecomp.el | 18 ++++++---- lisp/keymap.el | 11 +++--- 6 files changed, 126 insertions(+), 30 deletions(-) (limited to 'lisp/emacs-lisp') diff --git a/doc/lispref/elisp.texi b/doc/lispref/elisp.texi index 3254a4dba81..91926e05794 100644 --- a/doc/lispref/elisp.texi +++ b/doc/lispref/elisp.texi @@ -448,6 +448,9 @@ Symbols * Creating Symbols:: How symbols are kept unique. * Symbol Properties:: Each symbol has a property list for recording miscellaneous information. +* Shorthands:: Properly organize your symbol names but + type less of them. +* Symbols with Position:: Symbol variants containing integer positions Symbol Properties diff --git a/doc/lispref/streams.texi b/doc/lispref/streams.texi index c6b3397ae11..4cc8b89234d 100644 --- a/doc/lispref/streams.texi +++ b/doc/lispref/streams.texi @@ -326,6 +326,16 @@ For example: @end group @end example @end defun +@end defun + +@defun read-positioning-symbols &optional stream +This function reads one textual expression from @var{stream}, like +@code{read} does, but additionally positions the read symbols to the +positions in @var{stream} where they occurred. Only the symbol +@code{nil} is not positioned, this for efficiency reasons. +@xref{Symbols with Position}. This function is used by the byte +compiler. +@end defun @defvar standard-input This variable holds the default input stream---the stream that diff --git a/doc/lispref/symbols.texi b/doc/lispref/symbols.texi index a951e9be8ae..f3a9e586e36 100644 --- a/doc/lispref/symbols.texi +++ b/doc/lispref/symbols.texi @@ -23,15 +23,15 @@ otherwise. @end defun @menu -* Symbol Components:: Symbols have names, values, function definitions +* Symbol Components:: Symbols have names, values, function definitions and property lists. -* Definitions:: A definition says how a symbol will be used. -* Creating Symbols:: How symbols are kept unique. -* Symbol Properties:: Each symbol has a property list +* Definitions:: A definition says how a symbol will be used. +* Creating Symbols:: How symbols are kept unique. +* Symbol Properties:: Each symbol has a property list for recording miscellaneous information. -* Shorthands:: Properly organize your symbol names but +* Shorthands:: Properly organize your symbol names but type less of them. - +* Symbols with Position:: Symbol variants containing integer positions @end menu @node Symbol Components @@ -432,8 +432,8 @@ symbol's property list cell (@pxref{Symbol Components}), in the form of a property list (@pxref{Property Lists}). @menu -* Symbol Plists:: Accessing symbol properties. -* Standard Properties:: Standard meanings of symbol properties. +* Symbol Plists:: Accessing symbol properties. +* Standard Properties:: Standard meanings of symbol properties. @end menu @node Symbol Plists @@ -751,3 +751,69 @@ those names. @item Symbol forms whose names start with @samp{#_} are not transformed. @end itemize + +@node Symbols with Position +@section Symbols with Position +@cindex symbols with position + +A @dfn{symbol with position} is a symbol, the @dfn{bare symbol}, +together with an unsigned integer called the @dfn{position}. These +objects are intended for use by the byte compiler, which records in +them the position of each symbol occurrence and uses those positions +in warning and error messages. + +The printed representation of a symbol with position uses the hash +notation outlined in @ref{Printed Representation}. It looks like +@samp{#}. It has no read syntax. You can cause +just the bare symbol to be printed by binding the variable +@code{print-symbols-bare} to non-@code{nil} around the print +operation. The byte compiler does this before writing its output to +the compiled Lisp file. + +For most purposes, when the flag variable +@code{symbols-with-pos-enabled} is non-@code{nil}, symbols with +positions behave just as bare symbols do. For example, @samp{(eq +# foo)} has a value @code{t} when that variable +is set (but nil when it isn't set). Most of the time in Emacs this +variable is @code{nil}, but the byte compiler binds it to @code{t} +when it runs. + +Typically, symbols with position are created by the byte compiler +calling the reader function @code{read-positioning-symbols} +(@pxref{Input Functions}). One can also be created with the function +@code{position-symbol}. + +@defvar symbols-with-pos-enabled +When this variable is non-@code{nil}, symbols with position behave +like the contained bare symbol. Emacs runs a little more slowly in +this case. +@end defvar + +@defvar print-symbols-bare +When bound to non-nil, the Lisp printer prints only the bare symbol of +a symbol with position, ignoring the position. +@end defvar + +@defun symbol-with-pos-p symbol. +This function returns @code{t} if @var{symbol} is a symbol with +position, @code{nil} otherwise. +@end defun + +@defun bare-symbol symbol +This function returns the bare symbol contained in @var{symbol}, or +@var{symbol} itself if it is already a bare symbol. For any other +type of object, it throws an error. +@end defun + +@defun symbol-with-pos-pos symbol +This function returns the position, a number, from a symbol with +position. For any other type of object, it throws an error. +@end defun + +@defun position-symbol sym pos +Make a new symbol with position. @var{sym} is either a bare symbol or +a symbol with position, and supplies the symbol part of the new +object. @var{pos} is either an integer which becomes the number part +of the new object, or a symbol with position whose position is used. +Emacs throws an error if either argument is invalid. +@end defun diff --git a/lisp/cedet/semantic/fw.el b/lisp/cedet/semantic/fw.el index fd61751cb50..b7c3461a4d7 100644 --- a/lisp/cedet/semantic/fw.el +++ b/lisp/cedet/semantic/fw.el @@ -191,12 +191,20 @@ will throw a warning when it encounters this symbol." (not (string-match "cedet" (macroexp-file-name))) ) (make-obsolete-overload oldfnalias newfn when) - (byte-compile-warn - "%s: `%s' obsoletes overload `%s'" - (macroexp-file-name) - newfn - (with-suppressed-warnings ((obsolete semantic-overload-symbol-from-function)) - (semantic-overload-symbol-from-function oldfnalias))))) + (if (fboundp 'byte-compile-warn-x) + (byte-compile-warn-x + newfn + "%s: `%s' obsoletes overload `%s'" + (macroexp-file-name) + newfn + (with-suppressed-warnings ((obsolete semantic-overload-symbol-from-function)) + (semantic-overload-symbol-from-function oldfnalias))) + (byte-compile-warn + "%s: `%s' obsoletes overload `%s'" + (macroexp-file-name) + newfn + (with-suppressed-warnings ((obsolete semantic-overload-symbol-from-function)) + (semantic-overload-symbol-from-function oldfnalias)))))) (defun semantic-varalias-obsolete (oldvaralias newvar when) "Make OLDVARALIAS an alias for variable NEWVAR. @@ -209,10 +217,14 @@ will throw a warning when it encounters this symbol." (error ;; Only throw this warning when byte compiling things. (when (macroexp-compiling-p) - (byte-compile-warn - "variable `%s' obsoletes, but isn't alias of `%s'" - newvar oldvaralias) - )))) + (if (fboundp 'byte-compile-warn-x) + (byte-compile-warn-x + newvar + "variable `%s' obsoletes, but isn't alias of `%s'" + newvar oldvaralias) + (byte-compile-warn + "variable `%s' obsoletes, but isn't alias of `%s'" + newvar oldvaralias)))))) ;;; Help debugging ;; diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 41d2126dbcf..587819f36ed 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1309,20 +1309,21 @@ Called with arguments (STRING POSITION FILL LEVEL). STRING is a message describing the problem. POSITION is a buffer position where the problem was detected. FILL is a prefix as in `warning-fill-prefix'. LEVEL is the level of the -problem (`:warning' or `:error'). POSITION, FILL and LEVEL may be -nil.") +problem (`:warning' or `:error'). FILL and LEVEL may be nil.") (defun byte-compile-log-warning (string &optional fill level) "Log a byte-compilation warning. STRING, FILL and LEVEL are as described in `byte-compile-log-warning-function', which see." (funcall byte-compile-log-warning-function - string nil + string + (or (byte-compile--warning-source-offset) + (point)) fill level)) -(defun byte-compile--log-warning-for-byte-compile (string &optional - _position +(defun byte-compile--log-warning-for-byte-compile (string _position + &optional fill level) "Log a message STRING in `byte-compile-log-buffer'. @@ -2653,8 +2654,11 @@ list that represents a doc string reference. (put 'require 'byte-hunk-handler 'byte-compile-file-form-require) (defun byte-compile-file-form-require (form) - (let ((args (mapcar 'eval (cdr form))) - hist-new prov-cons) + (let* ((args (mapcar 'eval (cdr form))) + ;; The following is for the byte-compile-warn in + ;; `do-after-load-evaluation' (in subr.el). + (byte-compile-form-stack (cons (car args) byte-compile-form-stack)) + hist-new prov-cons) (apply 'require args) ;; Record the functions defined by the require in `byte-compile-new-defuns'. diff --git a/lisp/keymap.el b/lisp/keymap.el index 3e9189fba45..ce566fd8afc 100644 --- a/lisp/keymap.el +++ b/lisp/keymap.el @@ -462,18 +462,19 @@ If MESSAGE (and interactively), message the result." (keywordp (car args)) (not (eq (car args) :menu))) (unless (memq (car args) '(:full :keymap :parent :suppress :name :prefix)) - (byte-compile-warn "Invalid keyword: %s" (car args))) + (byte-compile-warn-x (car args) "Invalid keyword: %s" (car args))) (setq args (cdr args)) (when (null args) - (byte-compile-warn "Uneven number of keywords in %S" form)) + (byte-compile-warn-x form "Uneven number of keywords in %S" form)) (setq args (cdr args))) ;; Bindings. (while args - (let ((key (pop args))) + (let* ((wargs args) + (key (pop args))) (when (and (stringp key) (not (key-valid-p key))) - (byte-compile-warn "Invalid `kbd' syntax: %S" key))) + (byte-compile-warn-x wargs "Invalid `kbd' syntax: %S" key))) (when (null args) - (byte-compile-warn "Uneven number of key bindings in %S" form)) + (byte-compile-warn-x form "Uneven number of key bindings in %S" form)) (setq args (cdr args))) form) -- cgit v1.2.3