mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-01-05 19:31:02 -08:00
Code Issues Projects Releases Wiki Activity

Commit fixes and enhancements to the scratch/correct-warning-pos branch

Browse source 
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.
This commit is contained in:
Alan Mackenzie 2022-01-14 19:06:04 +00:00
parent 2128cd8c08
commit 57b698f159
7 changed files with 296 additions and 295 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -30,6 +30,83 @@
;;; Code: ;;; 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 (defalias 'function-put
;; We don't want people to just use `put' because we can't conveniently ;; 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 ;; 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. "Set FUNCTION's property PROP to VALUE.
The namespace for PROP is shared with symbols. The namespace for PROP is shared with symbols.
So far, FUNCTION can only be a symbol, not a lambda expression." 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 'doc-string-elt 3)
(function-put 'defmacro 'lisp-indent-function 2) (function-put 'defmacro 'lisp-indent-function 2)

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

@ -460,12 +460,6 @@ Filled in `cconv-analyze-form' but initialized and consulted here.")
(defvar byte-compiler-error-flag) (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) (defun byte-compile-recurse-toplevel (form non-toplevel-case)
"Implement `eval-when-compile' and `eval-and-compile'. "Implement `eval-when-compile' and `eval-and-compile'.
Return the compile-time value of FORM." Return the compile-time value of FORM."
@ -506,9 +500,8 @@ Return the compile-time value of FORM."
byte-compile-new-defuns)) byte-compile-new-defuns))
(setf result (setf result
(byte-compile-eval (byte-compile-eval
(macroexp-strip-symbol-positions
(byte-compile-top-level (byte-compile-top-level
(byte-compile-preprocess form)))))))) (byte-compile-preprocess form)))))))
(list 'quote result)))) (list 'quote result))))
(eval-and-compile . ,(lambda (&rest body) (eval-and-compile . ,(lambda (&rest body)
(byte-compile-recurse-toplevel (byte-compile-recurse-toplevel
@ -517,10 +510,11 @@ Return the compile-time value of FORM."
;; Don't compile here, since we don't know ;; Don't compile here, since we don't know
;; whether to compile as byte-compile-form ;; whether to compile as byte-compile-form
;; or byte-compile-file-form. ;; or byte-compile-file-form.
(let ((expanded (let* ((print-symbols-bare t)
(macroexpand--all-toplevel (expanded
form (macroexpand--all-toplevel
macroexpand-all-environment))) form
macroexpand-all-environment)))
(eval expanded lexical-binding) (eval expanded lexical-binding)
expanded))))) expanded)))))
(with-suppressed-warnings (with-suppressed-warnings
@ -1248,10 +1242,10 @@ Here, \"first\" is by a depth first search."
(t 0)))) (t 0))))
(defun byte-compile--warning-source-offset () (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." Return nil if such is not found."
(catch 'offset (catch 'offset
(dolist (form byte-compile--form-stack) (dolist (form byte-compile-form-stack)
(let ((s (byte-compile--first-symbol form))) (let ((s (byte-compile--first-symbol form)))
(if (symbol-with-pos-p s) (if (symbol-with-pos-p s)
(throw 'offset (symbol-with-pos-pos 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) (defun byte-compile-warn (format &rest args)
"Issue a byte compiler warning; use (format-message FORMAT ARGS...) for message." "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)) (setq format (apply #'format-message format args))
(if byte-compile-error-on-warn (if byte-compile-error-on-warn
(error "%s" format) ; byte-compile-file catches and logs it (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 ARG is the source element (likely a symbol with position) central to
the warning, intended to supply source position information. the warning, intended to supply source position information.
FORMAT and ARGS are as in `byte-compile-warn'." 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))) (apply #'byte-compile-warn format args)))
(defun byte-compile-warn-obsolete (symbol) (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 (warning-series-started
(and (markerp warning-series) (and (markerp warning-series)
(eq (marker-buffer 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) (if (or (eq warning-series 'byte-compile-warning-series)
warning-series-started) warning-series-started)
;; warning-series does come from compilation, ;; 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))))) (write-region (point-min) (point-max) dynvar-file)))))
(if load (if load
(load target-file)) (load target-file))
t))) 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 ;;; compiling a single function
;;;###autoload ;;;###autoload
@ -2272,7 +2263,8 @@ With argument ARG, insert value in current buffer after the form."
(save-excursion (save-excursion
(end-of-defun) (end-of-defun)
(beginning-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-current-buffer (current-buffer))
(byte-compile-read-position (point)) (byte-compile-read-position (point))
(byte-compile-last-position byte-compile-read-position) (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) (read-symbol-positions-list nil)
;; #### This is bound in b-c-close-variables. ;; #### This is bound in b-c-close-variables.
;; (byte-compile-warnings byte-compile-warnings) ;; (byte-compile-warnings byte-compile-warnings)
) (symbols-with-pos-enabled t))
(byte-compile-close-variables (byte-compile-close-variables
(with-current-buffer (with-current-buffer
(setq byte-compile--outbuffer (setq byte-compile--outbuffer
@ -2432,11 +2424,10 @@ Call from the source buffer."
;; it here. ;; it here.
(when byte-native-compiling (when byte-native-compiling
;; Spill output for the native compiler here ;; Spill output for the native compiler here
(push (push (make-byte-to-native-top-level :form form :lexical lexical-binding)
(macroexp-strip-symbol-positions byte-to-native-top-level-forms))
(make-byte-to-native-top-level :form form :lexical lexical-binding)) (let ((print-symbols-bare t)
byte-to-native-top-level-forms)) (print-escape-newlines t)
(let ((print-escape-newlines t)
(print-length nil) (print-length nil)
(print-level nil) (print-level nil)
(print-quoted t) (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. ;; in the input buffer (now current), not in the output buffer.
(let ((dynamic-docstrings byte-compile-dynamic-docstrings)) (let ((dynamic-docstrings byte-compile-dynamic-docstrings))
(with-current-buffer byte-compile--outbuffer (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. ;; Insert the doc string, and make it a comment with #@LENGTH.
(and (>= (nth 1 info) 0) (and (>= (nth 1 info) 0)
dynamic-docstrings dynamic-docstrings
@ -2596,13 +2587,16 @@ list that represents a doc string reference.
;; byte-hunk-handlers cannot call this! ;; byte-hunk-handlers cannot call this!
(defun byte-compile-toplevel-file-form (top-level-form) (defun byte-compile-toplevel-file-form (top-level-form)
(let ((byte-compile--form-stack ;; (let ((byte-compile-form-stack
(cons top-level-form byte-compile--form-stack))) ;; (cons top-level-form byte-compile-form-stack)))
(byte-compile-recurse-toplevel (push top-level-form byte-compile-form-stack)
top-level-form (prog1
(lambda (form) (byte-compile-recurse-toplevel
(let ((byte-compile-current-form nil)) ; close over this for warnings. top-level-form
(byte-compile-file-form (byte-compile-preprocess form t))))))) (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. ;; byte-hunk-handlers can call this.
(defun byte-compile-file-form (form) (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 ;; byte-compile-noruntime-functions, in case we have an autoload
;; of foo-func following an (eval-when-compile (require 'foo)). ;; of foo-func following an (eval-when-compile (require 'foo)).
(unless (fboundp funsym) (unless (fboundp funsym)
(push (macroexp-strip-symbol-positions (push (cons funsym (cons 'autoload (cdr (cdr form))))
(cons funsym (cons 'autoload (cdr (cdr form)))))
byte-compile-function-environment)) byte-compile-function-environment))
;; If an autoload occurs _before_ the first call to a function, ;; If an autoload occurs _before_ the first call to a function,
;; byte-compile-callargs-warn does not add an entry to ;; 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) (delq (assq funsym byte-compile-unresolved-functions)
byte-compile-unresolved-functions))))) byte-compile-unresolved-functions)))))
(if (stringp (nth 3 form)) (if (stringp (nth 3 form))
(prog1 (macroexp-strip-symbol-positions form) (prog1
form
(byte-compile-docstring-length-warn form)) (byte-compile-docstring-length-warn form))
;; No doc string, so we can compile this as a normal form. ;; No doc string, so we can compile this as a normal form.
(byte-compile-keep-pending form 'byte-compile-normal-call))) (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))) (byte-compile-top-level (nth 2 form) nil 'file)))
((symbolp (nth 2 form)) ((symbolp (nth 2 form))
(setcar (cddr form) (bare-symbol (nth 2 form)))) (setcar (cddr form) (bare-symbol (nth 2 form))))
(t (setcar (cddr form) (t (setcar (cddr form) (nth 2 form))))
(macroexp-strip-symbol-positions (nth 2 form)))))
(setcar form (bare-symbol (car form))) (setcar form (bare-symbol (car form)))
(if (symbolp (nth 1 form)) (if (symbolp (nth 1 form))
(setcar (cdr form) (bare-symbol (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) (defun byte-compile-file-form-make-obsolete (form)
(prog1 (byte-compile-keep-pending form) (prog1 (byte-compile-keep-pending form)
(apply 'make-obsolete (apply 'make-obsolete
(mapcar 'eval (mapcar 'eval (cdr form)))))
(macroexp-strip-symbol-positions (cdr form))))))
(defun byte-compile-file-form-defmumble (name macro arglist body rest) (defun byte-compile-file-form-defmumble (name macro arglist body rest)
"Process a `defalias' for NAME. "Process a `defalias' for NAME.
@ -2894,14 +2886,13 @@ not to take responsibility for the actual compilation of the code."
(when byte-native-compiling (when byte-native-compiling
;; Spill output for the native compiler here. ;; Spill output for the native compiler here.
(push (push
(macroexp-strip-symbol-positions
(if macro (if macro
(make-byte-to-native-top-level (make-byte-to-native-top-level
:form `(defalias ',name '(macro . ,code) nil) :form `(defalias ',name '(macro . ,code) nil)
:lexical lexical-binding) :lexical lexical-binding)
(make-byte-to-native-func-def :name name (make-byte-to-native-func-def :name name
:byte-func code))) :byte-func code))
byte-to-native-top-level-forms)) byte-to-native-top-level-forms))
;; Output the form by hand, that's much simpler than having ;; Output the form by hand, that's much simpler than having
;; b-c-output-file-form analyze the defalias. ;; b-c-output-file-form analyze the defalias.
(byte-compile-output-docform (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))) (setq fun (eval fun t)))
(if macro (push 'macro fun)) (if macro (push 'macro fun))
(if (symbolp form) (fset form fun)) (if (symbolp form) (fset form fun))
fun))) fun))))))))
(setq byte-to-native-top-level-forms
(macroexp-strip-symbol-positions byte-to-native-top-level-forms)))))))
(defun byte-compile-sexp (sexp) (defun byte-compile-sexp (sexp)
"Compile and return SEXP." "Compile and return SEXP."
@ -3169,8 +3158,7 @@ for symbols generated by the byte compiler itself."
;; which may include "calls" to ;; which may include "calls" to
;; internal-make-closure (Bug#29988). ;; internal-make-closure (Bug#29988).
lexical-binding) lexical-binding)
(setq int (macroexp-strip-symbol-positions `(interactive ,newform))) (setq int `(interactive ,newform)))))
(setq int (macroexp-strip-symbol-positions int)))))
((cdr int) ; Invalid (interactive . something). ((cdr int) ; Invalid (interactive . something).
(byte-compile-warn-x int "malformed interactive spec: %s" (byte-compile-warn-x int "malformed interactive spec: %s"
int)))) int))))
@ -3185,7 +3173,7 @@ for symbols generated by the byte compiler itself."
(byte-compile-make-lambda-lexenv (byte-compile-make-lambda-lexenv
arglistvars)) arglistvars))
reserved-csts)) reserved-csts))
(bare-arglist (macroexp-strip-symbol-positions arglist))) (bare-arglist arglist))
;; Build the actual byte-coded function. ;; Build the actual byte-coded function.
(cl-assert (eq 'byte-code (car-safe compiled))) (cl-assert (eq 'byte-code (car-safe compiled)))
(let ((out (let ((out
@ -3208,9 +3196,7 @@ for symbols generated by the byte compiler itself."
(cond (cond
;; We have some command modes, so use the vector form. ;; We have some command modes, so use the vector form.
(command-modes (command-modes
(list (vector (nth 1 int) (list (vector (nth 1 int) command-modes)))
(macroexp-strip-symbol-positions
command-modes))))
;; No command modes, use the simple form with just the ;; No command modes, use the simple form with just the
;; interactive spec. ;; interactive spec.
(int (int
@ -3425,8 +3411,8 @@ for symbols generated by the byte compiler itself."
;; byte-compile--for-effect flag too.) ;; byte-compile--for-effect flag too.)
;; ;;
(defun byte-compile-form (form &optional for-effect) (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))) (push form byte-compile-form-stack)
(cond (cond
((not (consp form)) ((not (consp form))
(cond ((or (not (symbolp form)) (macroexp--const-symbol-p 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)) (setq byte-compile--for-effect nil))
((byte-compile-normal-call form))) ((byte-compile-normal-call form)))
(if byte-compile--for-effect (if byte-compile--for-effect
(byte-compile-discard)))) (byte-compile-discard))
(pop byte-compile-form-stack)))
(defun byte-compile-normal-call (form) (defun byte-compile-normal-call (form)
(when (and (symbolp (car form)) (when (and (symbolp (car form))
@ -3756,8 +3743,7 @@ assignment (i.e. `setq')."
(setq const (bare-symbol const))) (setq const (bare-symbol const)))
(byte-compile-out (byte-compile-out
'byte-constant 'byte-constant
(byte-compile-get-constant (byte-compile-get-constant const)))
(macroexp-strip-symbol-positions const))))
;; Compile those primitive ordinary functions ;; Compile those primitive ordinary functions
;; which have special byte codes just for speed. ;; which have special byte codes just for speed.
@ -4591,7 +4577,7 @@ Return (TAIL VAR TEST CASES), where:
(dolist (case cases) (dolist (case cases)
(setq tag (byte-compile-make-tag) (setq tag (byte-compile-make-tag)
test-objects (macroexp-strip-symbol-positions (car case)) test-objects (car case)
body (cdr case)) body (cdr case))
(byte-compile-out-tag tag) (byte-compile-out-tag tag)
(dolist (value test-objects) (dolist (value test-objects)
@ -5241,9 +5227,9 @@ OP and OPERAND are as passed to `byte-compile-out'."
;;; call tree stuff ;;; call tree stuff
(defun byte-compile-annotate-call-tree (form) (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)) byte-compile-current-form))
(bare-car-form (macroexp-strip-symbol-positions (car form))) (bare-car-form (byte-run-strip-symbol-positions (car form)))
entry) entry)
;; annotate the current call ;; annotate the current call
(if (setq entry (assq bare-car-form byte-compile-call-tree)) (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))) (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 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)))) (kill-emacs (if error 1 0))))
(defun batch-byte-compile-file (file) (defun batch-byte-compile-file (file)

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

@ -3517,9 +3517,8 @@ and then returning foo."
`(eval-and-compile `(eval-and-compile
;; Name the compiler-macro function, so that `symbol-file' can find it. ;; Name the compiler-macro function, so that `symbol-file' can find it.
(cl-defun ,fname ,(if (memq '&whole args) (delq '&whole args) (cl-defun ,fname ,(if (memq '&whole args) (delq '&whole args)
(cons '_cl-whole-arg (cons '_cl-whole-arg args))
(macroexp-strip-symbol-positions args))) ,@body)
,@(macroexp-strip-symbol-positions body))
(put ',func 'compiler-macro #',fname)))) (put ',func 'compiler-macro #',fname))))
;;;###autoload ;;;###autoload

4
lisp/emacs-lisp/comp.el
View file

@ -4004,7 +4004,9 @@ the deferred compilation mechanism."
(signal 'native-compiler-error (signal 'native-compiler-error
(list "Not a function symbol or file" function-or-file))) (list "Not a function symbol or file" function-or-file)))
(catch 'no-native-compile (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) (comp-native-compiling t)
(byte-native-qualities nil) (byte-native-qualities nil)
(symbols-with-pos-enabled t) (symbols-with-pos-enabled t)

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

@ -28,82 +28,21 @@
;;; Code: ;;; 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 ;; Bound by the top-level `macroexpand-all', and modified to include any
;; macros defined by `defmacro'. ;; macros defined by `defmacro'.
(defvar macroexpand-all-environment nil) (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) (defun macroexp--cons (car cdr original-cons)
"Return ORIGINAL-CONS if the car/cdr of it is `eq' to CAR and CDR, respectively. "Return ORIGINAL-CONS if the car/cdr of it is `eq' to CAR and CDR, respectively.
If not, return (CAR . CDR)." If not, return (CAR . CDR)."
@ -378,120 +317,122 @@ Only valid during macro-expansion."
"Expand all macros in FORM. "Expand all macros in FORM.
This is an internal version of `macroexpand-all'. This is an internal version of `macroexpand-all'.
Assumes the caller has bound `macroexpand-all-environment'." Assumes the caller has bound `macroexpand-all-environment'."
(if (eq (car-safe form) 'backquote-list*) (push form byte-compile-form-stack)
;; Special-case `backquote-list*', as it is normally a macro that (prog1
;; generates exceedingly deep expansions from relatively shallow input (if (eq (car-safe form) 'backquote-list*)
;; forms. We just process it `in reverse' -- first we expand all the ;; Special-case `backquote-list*', as it is normally a macro that
;; arguments, _then_ we expand the top-level definition. ;; generates exceedingly deep expansions from relatively shallow input
(macroexpand (macroexp--all-forms form 1) ;; forms. We just process it `in reverse' -- first we expand all the
macroexpand-all-environment) ;; arguments, _then_ we expand the top-level definition.
;; Normal form; get its expansion, and then expand arguments. (macroexpand (macroexp--all-forms form 1)
(setq form (macroexp-macroexpand form macroexpand-all-environment)) macroexpand-all-environment)
;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when ;; Normal form; get its expansion, and then expand arguments.
;; I tried it, it broke the bootstrap :-( (setq form (macroexp-macroexpand form macroexpand-all-environment))
(pcase form ;; FIXME: It'd be nice to use `byte-optimize--pcase' here, but when
(`(cond . ,clauses) ;; I tried it, it broke the bootstrap :-(
(macroexp--cons 'cond (macroexp--all-clauses clauses) form)) (pcase form
(`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) (`(cond . ,clauses)
(macroexp--cons (macroexp--cons 'cond (macroexp--all-clauses clauses) form))
'condition-case (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare))
(macroexp--cons err (macroexp--cons
(macroexp--cons (macroexp--expand-all body) 'condition-case
(macroexp--all-clauses handlers 1) (macroexp--cons err
(cddr form)) (macroexp--cons (macroexp--expand-all body)
(cdr form)) (macroexp--all-clauses handlers 1)
form)) (cddr form))
(`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) (cdr form))
(push name macroexp--dynvars) form))
(macroexp--all-forms form 2)) (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_)
(`(function ,(and f `(lambda . ,_))) (push name macroexp--dynvars)
(let ((macroexp--dynvars macroexp--dynvars)) (macroexp--all-forms form 2))
(macroexp--cons 'function (`(function ,(and f `(lambda . ,_)))
(macroexp--cons (macroexp--all-forms f 2) (let ((macroexp--dynvars macroexp--dynvars))
nil (macroexp--cons 'function
(cdr form)) (macroexp--cons (macroexp--all-forms f 2)
form))) nil
(`(,(or 'function 'quote) . ,_) form) (cdr form))
(`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) form)))
pcase--dontcare)) (`(,(or 'function 'quote) . ,_) form)
(let ((macroexp--dynvars macroexp--dynvars)) (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body)
(macroexp--cons pcase--dontcare))
fun (let ((macroexp--dynvars macroexp--dynvars))
(macroexp--cons (macroexp--cons
(macroexp--all-clauses bindings 1) fun
(if (null body) (macroexp--cons
(macroexp-unprogn (macroexp--all-clauses bindings 1)
(macroexp-warn-and-return (if (null body)
fun (macroexp-unprogn
(format "Empty %s body" fun) (macroexp-warn-and-return
nil nil 'compile-only)) fun
(macroexp--all-forms body)) (format "Empty %s body" fun)
(cdr form)) nil nil 'compile-only))
form))) (macroexp--all-forms body))
(`(,(and fun `(lambda . ,_)) . ,args) (cdr form))
;; Embedded lambda in function position. form)))
;; If the byte-optimizer is loaded, try to unfold this, (`(,(and fun `(lambda . ,_)) . ,args)
;; i.e. rewrite it to (let (<args>) <body>). We'd do it in the optimizer ;; Embedded lambda in function position.
;; anyway, but doing it here (i.e. earlier) can sometimes avoid the ;; If the byte-optimizer is loaded, try to unfold this,
;; creation of a closure, thus resulting in much better code. ;; i.e. rewrite it to (let (<args>) <body>). We'd do it in the optimizer
(let ((newform (macroexp--unfold-lambda form))) ;; anyway, but doing it here (i.e. earlier) can sometimes avoid the
(if (eq newform form) ;; creation of a closure, thus resulting in much better code.
;; Unfolding failed for some reason, avoid infinite recursion. (let ((newform (macroexp--unfold-lambda form)))
(macroexp--cons (macroexp--all-forms fun 2) (if (eq newform form)
(macroexp--all-forms args) ;; Unfolding failed for some reason, avoid infinite recursion.
form) (macroexp--cons (macroexp--all-forms fun 2)
(macroexp--expand-all newform)))) (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))))))
(`(funcall . ,(or `(,exp . ,args) pcase--dontcare)) (_ form)))
(let ((eexp (macroexp--expand-all exp)) (pop byte-compile-form-stack)))
(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))))
;; Record which arguments expect functions, so we can warn when those ;; Record which arguments expect functions, so we can warn when those
;; are accidentally quoted with ' rather than with #' ;; 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) (defun internal-macroexpand-for-load (form full-p)
;; Called from the eager-macroexpansion in readevalloop. ;; Called from the eager-macroexpansion in readevalloop.
(setq form (macroexp-strip-symbol-positions form)) (let ((symbols-with-pos-enabled t)
(cond (print-symbols-bare t))
;; Don't repeat the same warning for every top-level element. (cond
((eq 'skip (car macroexp--pending-eager-loads)) form) ;; Don't repeat the same warning for every top-level element.
;; If we detect a cycle, skip macro-expansion for now, and output a warning ((eq 'skip (car macroexp--pending-eager-loads)) form)
;; with a trimmed backtrace. ;; If we detect a cycle, skip macro-expansion for now, and output a warning
((and load-file-name (member load-file-name macroexp--pending-eager-loads)) ;; with a trimmed backtrace.
(let* ((bt (delq nil ((and load-file-name (member load-file-name macroexp--pending-eager-loads))
(mapcar #'macroexp--trim-backtrace-frame (let* ((bt (delq nil
(macroexp--backtrace)))) (mapcar #'macroexp--trim-backtrace-frame
(elem `(load ,(file-name-nondirectory load-file-name))) (macroexp--backtrace))))
(tail (member elem (cdr (member elem bt))))) (elem `(load ,(file-name-nondirectory load-file-name)))
(if tail (setcdr tail (list '…))) (tail (member elem (cdr (member elem bt)))))
(if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) (if tail (setcdr tail (list '…)))
(if macroexp--debug-eager (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt)))
(debug 'eager-macroexp-cycle) (if macroexp--debug-eager
(message "Warning: Eager macro-expansion skipped due to cycle:\n %s" (debug 'eager-macroexp-cycle)
(mapconcat #'prin1-to-string (nreverse bt) " => "))) (message "Warning: Eager macro-expansion skipped due to cycle:\n %s"
(push 'skip macroexp--pending-eager-loads) (mapconcat #'prin1-to-string (nreverse bt) " => ")))
form)) (push 'skip macroexp--pending-eager-loads)
(t form))
(condition-case err (t
(let ((macroexp--pending-eager-loads (condition-case err
(cons load-file-name macroexp--pending-eager-loads))) (let ((macroexp--pending-eager-loads
(if full-p (cons load-file-name macroexp--pending-eager-loads)))
(macroexpand--all-toplevel form) (if full-p
(macroexpand form))) (macroexpand--all-toplevel form)
(error (macroexpand form)))
;; Hopefully this shouldn't happen thanks to the cycle detection, (error
;; but in case it does happen, let's catch the error and give the ;; Hopefully this shouldn't happen thanks to the cycle detection,
;; code a chance to macro-expand later. ;; but in case it does happen, let's catch the error and give the
(message "Eager macro-expansion failure: %S" err) ;; code a chance to macro-expand later.
form))))) (message "Eager macro-expansion failure: %S" err)
form))))))
;; ¡¡¡ Big Ugly Hack !!! ;; ¡¡¡ Big Ugly Hack !!!
;; src/bootstrap-emacs is mostly used to compile .el files, so it needs ;; src/bootstrap-emacs is mostly used to compile .el files, so it needs

2
lisp/help.el
View file

@ -2069,7 +2069,7 @@ the same names as used in the original source code, when possible."
((symbolp arg) ((symbolp arg)
(let ((name (symbol-name arg))) (let ((name (symbol-name arg)))
(cond (cond
((string-match "\\`&" name) arg) ((string-match "\\`&" name) (bare-symbol arg))
((string-match "\\`_." name) ((string-match "\\`_." name)
(intern (upcase (substring name 1)))) (intern (upcase (substring name 1))))
(t (intern (upcase name)))))) (t (intern (upcase name))))))

5
src/fns.c
View file

@ -2414,11 +2414,6 @@ It can be retrieved with `(get SYMBOL PROPNAME)'. */)
(Lisp_Object symbol, Lisp_Object propname, Lisp_Object value) (Lisp_Object symbol, Lisp_Object propname, Lisp_Object value)
{ {
CHECK_SYMBOL (symbol); 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 set_symbol_plist
(symbol, Fplist_put (XSYMBOL (symbol)->u.s.plist, propname, value)); (symbol, Fplist_put (XSYMBOL (symbol)->u.s.plist, propname, value));
return value; return value;