diff options
Diffstat (limited to 'lisp/emacs-lisp')
| -rw-r--r-- | lisp/emacs-lisp/byte-run.el | 81 | ||||
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 116 | ||||
| -rw-r--r-- | lisp/emacs-lisp/cl-macs.el | 5 | ||||
| -rw-r--r-- | lisp/emacs-lisp/comp.el | 4 | ||||
| -rw-r--r-- | lisp/emacs-lisp/macroexp.el | 380 |
5 files changed, 296 insertions, 290 deletions
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 (<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)))))) - - (_ 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 (<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)))))) + + (_ 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 |