mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-13 09:32:47 +00:00
Code Issues Releases 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
Show Stats 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:
(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)

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

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

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

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

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

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

@ -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 (<args>) <body>). 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))))
(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 (<args>) <body>). 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))))))
(`(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))))
(_ 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

2
lisp/help.el
View File

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

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