diff options
Diffstat (limited to 'lisp/emacs-lisp/macroexp.el')
| -rw-r--r-- | lisp/emacs-lisp/macroexp.el | 389 |
1 files changed, 205 insertions, 184 deletions
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 168de1bf180..78601c0648e 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -39,6 +39,18 @@ 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.") +(defmacro macroexp--with-extended-form-stack (expr &rest body) + "Evaluate BODY with EXPR pushed onto `byte-compile-form-stack'." + (declare (indent 1)) + ;; FIXME: We really should just be using a simple dynamic let-binding here, + ;; but these explicit push and pop make the extended stack value visible + ;; to error handlers. Remove that need for that! + `(progn + (push ,expr byte-compile-form-stack) + (prog1 + (progn ,@body) + (pop byte-compile-form-stack)))) + ;; Bound by the top-level `macroexpand-all', and modified to include any ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) @@ -105,14 +117,21 @@ each clause." (macroexp--all-forms clause skip) clause))) +(defvar macroexp-inhibit-compiler-macros nil + "Inhibit application of compiler macros if non-nil.") + (defun macroexp--compiler-macro (handler form) - (condition-case-unless-debug err - (let ((symbols-with-pos-enabled t)) - (apply handler form (cdr form))) - (error - (message "Warning: Optimization failure for %S: Handler: %S\n%S" - (car form) handler err) - form))) + "Apply compiler macro HANDLER to FORM and return the result. +Unless `macroexp-inhibit-compiler-macros' is non-nil, in which +case return FORM unchanged." + (if macroexp-inhibit-compiler-macros + form + (condition-case-unless-debug err + (apply handler form (cdr form)) + (error + (message "Warning: Optimization failure for %S: Handler: %S\n%S" + (car form) handler err) + form)))) (defun macroexp--funcall-if-compiled (_form) "Pseudo function used internally by macroexp to delay warnings. @@ -227,84 +246,79 @@ It should normally be a symbol with position and it defaults to FORM." (defun macroexp-macroexpand (form env) "Like `macroexpand' but checking obsolescence." (let* ((macroexpand-all-environment env) - (new-form - (macroexpand form env))) - (if (and (not (eq form new-form)) ;It was a macro call. - (car-safe form) - (symbolp (car form)) - (get (car form) 'byte-obsolete-info)) - (let* ((fun (car form)) - (obsolete (get fun 'byte-obsolete-info))) - (macroexp-warn-and-return - (macroexp--obsolete-warning - fun obsolete - (if (symbolp (symbol-function fun)) - "alias" "macro")) - new-form (list 'obsolete fun) nil fun)) - new-form))) + new-form) + (while (not (eq form (setq new-form (macroexpand-1 form env)))) + (let ((fun (car-safe form))) + (setq form + (if (and fun (symbolp fun) + (get fun 'byte-obsolete-info)) + (macroexp-warn-and-return + (macroexp--obsolete-warning + fun (get fun 'byte-obsolete-info) + (if (symbolp (symbol-function fun)) "alias" "macro")) + new-form (list 'obsolete fun) nil fun) + new-form)))) + form)) (defun macroexp--unfold-lambda (form &optional name) - ;; In lexical-binding mode, let and functions don't bind vars in the same way - ;; (let obey special-variable-p, but functions don't). But luckily, this - ;; doesn't matter here, because function's behavior is underspecified so it - ;; can safely be turned into a `let', even though the reverse is not true. (or name (setq name "anonymous lambda")) - (let* ((lambda (car form)) - (values (cdr form)) - (arglist (nth 1 lambda)) - (body (cdr (cdr lambda))) - optionalp restp - bindings) - (if (and (stringp (car body)) (cdr body)) - (setq body (cdr body))) - (if (and (consp (car body)) (eq 'interactive (car (car body)))) - (setq body (cdr body))) - ;; FIXME: The checks below do not belong in an optimization phase. - (while arglist - (cond ((eq (car arglist) '&optional) - ;; ok, I'll let this slide because funcall_lambda() does... - ;; (if optionalp (error "Multiple &optional keywords in %s" name)) - (if restp (error "&optional found after &rest in %s" name)) - (if (null (cdr arglist)) - (error "Nothing after &optional in %s" name)) - (setq optionalp t)) - ((eq (car arglist) '&rest) - ;; ...but it is by no stretch of the imagination a reasonable - ;; thing that funcall_lambda() allows (&rest x y) and - ;; (&rest x &optional y) in arglists. - (if (null (cdr arglist)) - (error "Nothing after &rest in %s" name)) - (if (cdr (cdr arglist)) - (error "Multiple vars after &rest in %s" name)) - (setq restp t)) - (restp - (setq bindings (cons (list (car arglist) - (and values (cons 'list values))) - bindings) - values nil)) - ((and (not optionalp) (null values)) - (setq arglist nil values 'too-few)) - (t - (setq bindings (cons (list (car arglist) (car values)) - bindings) - values (cdr values)))) - (setq arglist (cdr arglist))) - (if values - (macroexp-warn-and-return - (format (if (eq values 'too-few) - "attempt to open-code `%s' with too few arguments" - "attempt to open-code `%s' with too many arguments") - name) - form nil nil arglist) - - ;; The following leads to infinite recursion when loading a - ;; file containing `(defsubst f () (f))', and then trying to - ;; byte-compile that file. - ;;(setq body (mapcar 'byte-optimize-form body))) - - (if bindings - `(let ,(nreverse bindings) . ,body) - (macroexp-progn body))))) + (pcase form + ((or `(funcall (function ,lambda) . ,actuals) `(,lambda . ,actuals)) + (let* ((formals (nth 1 lambda)) + (body (cdr (macroexp-parse-body (cddr lambda)))) + optionalp restp + (dynboundarg nil) + bindings) + ;; FIXME: The checks below do not belong in an optimization phase. + (while formals + (if (macroexp--dynamic-variable-p (car formals)) + (setq dynboundarg t)) + (cond ((eq (car formals) '&optional) + ;; ok, I'll let this slide because funcall_lambda() does... + ;; (if optionalp (error "Multiple &optional keywords in %s" name)) + (if restp (error "&optional found after &rest in %s" name)) + (if (null (cdr formals)) + (error "Nothing after &optional in %s" name)) + (setq optionalp t)) + ((eq (car formals) '&rest) + ;; ...but it is by no stretch of the imagination a reasonable + ;; thing that funcall_lambda() allows (&rest x y) and + ;; (&rest x &optional y) in formalss. + (if (null (cdr formals)) + (error "Nothing after &rest in %s" name)) + (if (cdr (cdr formals)) + (error "Multiple vars after &rest in %s" name)) + (setq restp t)) + (restp + (setq bindings (cons (list (car formals) + (and actuals (cons 'list actuals))) + bindings) + actuals nil)) + ((and (not optionalp) (null actuals)) + (setq formals nil actuals 'too-few)) + (t + (setq bindings (cons (list (car formals) (car actuals)) + bindings) + actuals (cdr actuals)))) + (setq formals (cdr formals))) + (cond + (actuals + (macroexp-warn-and-return + (format-message + (if (eq actuals 'too-few) + "attempt to open-code `%s' with too few arguments" + "attempt to open-code `%s' with too many arguments") + name) + form nil nil formals)) + ;; In lexical-binding mode, let and functions don't bind vars in + ;; the same way (let obey special-variable-p, but functions + ;; don't). So if one of the vars is declared as dynamically scoped, we + ;; can't just convert the call to `let'. + ;; FIXME: We should α-rename the affected args and then use `let'. + (dynboundarg form) + (bindings `(let ,(nreverse bindings) . ,body)) + (t (macroexp-progn body))))) + (_ (error "Not an unfoldable form: %S" form)))) (defun macroexp--dynamic-variable-p (var) "Whether the variable VAR is dynamically scoped. @@ -320,8 +334,7 @@ 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'." - (push form byte-compile-form-stack) - (prog1 + (macroexp--with-extended-form-stack form (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 @@ -336,16 +349,48 @@ Assumes the caller has bound `macroexpand-all-environment'." (let ((fn (car-safe form))) (pcase form (`(cond . ,clauses) - (macroexp--cons fn (macroexp--all-clauses clauses) form)) + ;; Check for rubbish clauses at the end before macro-expansion, + ;; to avoid nuisance warnings from clauses that become + ;; unconditional through that process. + ;; FIXME: this strategy is defeated by forced `macroexpand-all', + ;; such as in `cl-flet'. Haven't seen that in the wild, though. + (let ((default-tail nil) + (n 0) + (rest clauses)) + (while rest + (let ((c (car-safe (car rest)))) + (when (cond ((consp c) (and (memq (car c) '(quote function)) + (cadr c))) + ((symbolp c) (or (eq c t) (keywordp c))) + (t t)) + ;; This is unquestionably a default clause. + (setq default-tail (cdr rest)) + (setq clauses (take (1+ n) clauses)) ; trim the tail + (setq rest nil))) + (setq n (1+ n)) + (setq rest (cdr rest))) + (let ((expanded-form + (macroexp--cons fn (macroexp--all-clauses clauses) form))) + (if default-tail + (macroexp-warn-and-return + (format-message + "Useless clause following default `cond' clause") + expanded-form '(suspicious cond) t default-tail) + expanded-form)))) (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) - (macroexp--cons - fn - (macroexp--cons err - (macroexp--cons (macroexp--expand-all body) - (macroexp--all-clauses handlers 1) - (cddr form)) - (cdr form)) - form)) + (let ((exp-body (macroexp--expand-all body))) + (if handlers + (macroexp--cons fn + (macroexp--cons + err (macroexp--cons + exp-body + (macroexp--all-clauses handlers 1) + (cddr form)) + (cdr form)) + form) + (macroexp-warn-and-return + (format-message "`condition-case' without handlers") + exp-body (list 'suspicious 'condition-case) t form)))) (`(,(or 'defvar 'defconst) ,(and name (pred symbolp)) . ,_) (push name macroexp--dynvars) (macroexp--all-forms form 2)) @@ -367,16 +412,21 @@ Assumes the caller has bound `macroexpand-all-environment'." (if (null body) (macroexp-unprogn (macroexp-warn-and-return - (format "Empty %s body" fun) - nil nil 'compile-only fun)) + (format-message "`%s' with empty body" fun) + nil (list 'empty-body fun) 'compile-only fun)) (macroexp--all-forms body)) (cdr form)) form))) (`(while) (macroexp-warn-and-return - "missing `while' condition" + (format-message "missing `while' condition") `(signal 'wrong-number-of-arguments '(while 0)) nil 'compile-only form)) + (`(unwind-protect ,expr) + (macroexp-warn-and-return + (format-message "`unwind-protect' without unwind forms") + (macroexp--expand-all expr) + (list 'suspicious 'unwind-protect) t form)) (`(setq ,(and var (pred symbolp) (pred (not booleanp)) (pred (not keywordp))) ,expr) @@ -392,7 +442,7 @@ Assumes the caller has bound `macroexpand-all-environment'." (let ((nargs (length args))) (if (/= (logand nargs 1) 0) (macroexp-warn-and-return - "odd number of arguments in `setq' form" + (format-message "odd number of arguments in `setq' form") `(signal 'wrong-number-of-arguments '(setq ,nargs)) nil 'compile-only fn) (let ((assignments nil)) @@ -426,50 +476,31 @@ Assumes the caller has bound `macroexpand-all-environment'." (setq args (cddr args))) (cons 'progn (nreverse assignments)))))) (`(,(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)))) + (macroexp--cons (macroexp--all-forms fun 2) + (macroexp--all-forms args) + form)) (`(funcall ,exp . ,args) (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 + ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' + ;; has a compiler-macro, or to unfold it. ((and `#',f - (guard (not (or (special-form-p f) (macrop f))))) ;; bug#46636 + (guard (and (symbolp f) + ;; bug#46636 + (not (or (special-form-p f) (macrop f)))))) (macroexp--expand-all `(,f . ,eargs))) - (_ `(funcall ,eexp . ,eargs))))) + (`#'(lambda . ,_) + (macroexp--unfold-lambda `(,fn ,eexp . ,eargs))) + (_ `(,fn ,eexp . ,eargs))))) (`(funcall . ,_) form) ;bug#53227 (`(,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 - (format "%S quoted with ' rather than with #'" - (let ((f (cadr arg))) - (if (symbolp f) f `(lambda ,(nth 1 f) ...)))) - arg nil nil (cadr arg)))))) + (let ((handler (function-get func 'compiler-macro))) ;; 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). + ;; No compiler macro. We just expand each argument. (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. @@ -486,23 +517,9 @@ Assumes the caller has bound `macroexpand-all-environment'." (setq form (macroexp--compiler-macro handler newform)) (if (eq newform form) newform - (macroexp--expand-all newform))) + (macroexp--expand-all form))) (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 #' -(dolist (f '( funcall apply mapcar mapatoms mapconcat mapc cl-mapcar maphash - map-char-table map-keymap map-keymap-internal)) - (put f 'funarg-positions '(1))) -(dolist (f '( add-hook remove-hook advice-remove advice--remove-function - defalias fset global-set-key run-after-idle-timeout - set-process-filter set-process-sentinel sort)) - (put f 'funarg-positions '(2))) -(dolist (f '( advice-add define-key - run-at-time run-with-idle-timer run-with-timer )) - (put f 'funarg-positions '(3))) + (_ form)))))) ;;;###autoload (defun macroexpand-all (form &optional environment) @@ -526,11 +543,17 @@ definitions to shadow the loaded ones for use in file byte-compilation." (defun macroexp-parse-body (body) "Parse a function BODY into (DECLARATIONS . EXPS)." (let ((decls ())) - (while (and (cdr body) - (let ((e (car body))) - (or (stringp e) - (memq (car-safe e) - '(:documentation declare interactive cl-declare))))) + (while + (and body + (let ((e (car body))) + (or (and (stringp e) + ;; If there is only a string literal with + ;; nothing following, we consider this to be + ;; part of the body (the return value) rather + ;; than a declaration at this point. + (cdr body)) + (memq (car-safe e) + '(:documentation declare interactive cl-declare))))) (push (pop body) decls)) (cons (nreverse decls) body))) @@ -787,40 +810,38 @@ test of free variables in the following ways: (defun internal-macroexpand-for-load (form full-p) ;; Called from the eager-macroexpansion in readevalloop. - (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) - (error "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. - (error "Eager macro-expansion failure: %S" err) - 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) + (error "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))) + ((debug 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. + (error "Eager macro-expansion failure: %S" err) + form))))) ;; ¡¡¡ Big Ugly Hack !!! ;; src/bootstrap-emacs is mostly used to compile .el files, so it needs |