diff options
Diffstat (limited to 'lisp/emacs-lisp/macroexp.el')
| -rw-r--r-- | lisp/emacs-lisp/macroexp.el | 273 |
1 files changed, 213 insertions, 60 deletions
diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 82a8cd2d777..df864464b77 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -112,7 +112,7 @@ and also to avoid outputting the warning during normal execution." (funcall (eval (cadr form))) (byte-compile-constant nil))) -(defun macroexp--compiling-p () +(defun macroexp-compiling-p () "Return non-nil if we're macroexpanding for the compiler." ;; FIXME: ¡¡Major Ugly Hack!! To determine whether the output of this ;; macro-expansion will be processed by the byte-compiler, we check @@ -120,29 +120,48 @@ and also to avoid outputting the warning during normal execution." (member '(declare-function . byte-compile-macroexpand-declare-function) macroexpand-all-environment)) +(defun macroexp-file-name () + "Return the name of the file from which the code comes. +Returns nil when we do not know. +A non-nil result is expected to be reliable when called from a macro in order +to find the file in which the macro's call was found, and it should be +reliable as well when used at the top-level of a file. +Other uses risk returning non-nil value that point to the wrong file." + ;; `eval-buffer' binds `current-load-list' but not `load-file-name', + ;; so prefer using it over using `load-file-name'. + (let ((file (car (last current-load-list)))) + (or (if (stringp file) file) + (bound-and-true-p byte-compile-current-file)))) + (defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key)) -(defun macroexp--warn-and-return (msg form &optional compile-only) +(defun macroexp--warn-wrap (msg form) (let ((when-compiled (lambda () (byte-compile-warn "%s" msg)))) - (cond - ((null msg) form) - ((macroexp--compiling-p) - (if (gethash form macroexp--warned) - ;; Already wrapped this exp with a warning: avoid inf-looping - ;; where we keep adding the same warning onto `form' because - ;; macroexpand-all gets right back to macroexpanding `form'. - form - (puthash form form macroexp--warned) - `(progn - (macroexp--funcall-if-compiled ',when-compiled) - ,form))) - (t - (unless compile-only - (message "%s%s" (if (stringp load-file-name) - (concat (file-relative-name load-file-name) ": ") - "") - msg)) - form)))) + `(progn + (macroexp--funcall-if-compiled ',when-compiled) + ,form))) + +(define-obsolete-function-alias 'macroexp--warn-and-return + #'macroexp-warn-and-return "28.1") +(defun macroexp-warn-and-return (msg form &optional compile-only) + (cond + ((null msg) form) + ((macroexp-compiling-p) + (if (and (consp form) (gethash form macroexp--warned)) + ;; Already wrapped this exp with a warning: avoid inf-looping + ;; where we keep adding the same warning onto `form' because + ;; macroexpand-all gets right back to macroexpanding `form'. + form + (puthash form form macroexp--warned) + (macroexp--warn-wrap msg form))) + (t + (unless compile-only + (message "%sWarning: %s" + (if (stringp load-file-name) + (concat (file-relative-name load-file-name) ": ") + "") + msg)) + form))) (defun macroexp--obsolete-warning (fun obsolescence-data type) (let ((instead (car obsolescence-data)) @@ -180,8 +199,9 @@ and also to avoid outputting the warning during normal execution." (defun macroexp-macroexpand (form env) "Like `macroexpand' but checking obsolescence." - (let ((new-form - (macroexpand form env))) + (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)) @@ -190,7 +210,7 @@ and also to avoid outputting the warning during normal execution." (byte-compile-warning-enabled-p 'obsolete (car form)))) (let* ((fun (car form)) (obsolete (get fun 'byte-obsolete-info))) - (macroexp--warn-and-return + (macroexp-warn-and-return (macroexp--obsolete-warning fun obsolete (if (symbolp (symbol-function fun)) @@ -198,6 +218,69 @@ and also to avoid outputting the warning during normal execution." new-form)) new-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) + + ;; 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))))) + (defun macroexp--expand-all (form) "Expand all macros in FORM. This is an internal version of `macroexpand-all'. @@ -211,10 +294,12 @@ Assumes the caller has bound `macroexpand-all-environment'." 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) dontcare)) + (`(condition-case . ,(or `(,err ,body . ,handlers) pcase--dontcare)) (macroexp--cons 'condition-case (macroexp--cons err @@ -231,46 +316,57 @@ Assumes the caller has bound `macroexpand-all-environment'." (cdr form)) form)) (`(,(or 'function 'quote) . ,_) form) - (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) dontcare)) + (`(,(and fun (or 'let 'let*)) . ,(or `(,bindings . ,body) + pcase--dontcare)) (macroexp--cons fun (macroexp--cons (macroexp--all-clauses bindings 1) - (macroexp--all-forms body) + (if (null body) + (macroexp-unprogn + (macroexp-warn-and-return + (format "Empty %s body" fun) + nil t)) + (macroexp--all-forms body)) (cdr form)) form)) (`(,(and fun `(lambda . ,_)) . ,args) ;; Embedded lambda in function position. - (macroexp--cons (macroexp--all-forms fun 2) - (macroexp--all-forms args) - form)) - ;; The following few cases are for normal function calls that - ;; are known to funcall one of their arguments. The byte - ;; compiler has traditionally handled these functions specially - ;; by treating a lambda expression quoted by `quote' as if it - ;; were quoted by `function'. We make the same transformation - ;; here, so that any code that cares about the difference will - ;; see the same transformation. - ;; First arg is a function: - (`(,(and fun (or 'funcall 'apply 'mapcar 'mapatoms 'mapconcat 'mapc)) - ',(and f `(lambda . ,_)) . ,args) - (macroexp--warn-and-return - (format "%s quoted with ' rather than with #'" - (list 'lambda (nth 1 f) '...)) - (macroexp--expand-all `(,fun ,f . ,args)))) - ;; Second arg is a function: - (`(,(and fun (or 'sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args) - (macroexp--warn-and-return - (format "%s quoted with ' rather than with #'" - (list 'lambda (nth 1 f) '...)) - (macroexp--expand-all `(,fun ,arg1 ,f . ,args)))) - (`(funcall #',(and f (pred symbolp)) . ,args) - ;; Rewrite (funcall #'foo bar) to (foo bar), in case `foo' - ;; has a compiler-macro. - (macroexp--expand-all `(,f . ,args))) + ;; 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 . ,_) - ;; Macro expand compiler macros. This cannot be delayed to - ;; byte-optimize-form because the output of the compiler-macro can - ;; use macros. - (let ((handler (function-get func 'compiler-macro))) + (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))))) + ;; 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 @@ -296,6 +392,19 @@ Assumes the caller has bound `macroexpand-all-environment'." (_ form)))) +;; 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))) + ;;;###autoload (defun macroexpand-all (form &optional environment) "Return result of expanding macros at all levels in FORM. @@ -358,12 +467,12 @@ Never returns an empty list." (t `(cond (,test ,@(macroexp-unprogn then)) (,(nth 1 else) ,@(macroexp-unprogn (nth 2 else))) - (t ,@(nthcdr 3 else)))))) + ,@(let ((def (nthcdr 3 else))) (if def `((t ,@def)))))))) ((eq (car-safe else) 'cond) `(cond (,test ,@(macroexp-unprogn then)) ,@(cdr else))) ;; Invert the test if that lets us reduce the depth of the tree. ((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then)) - (t `(if ,test ,then ,@(macroexp-unprogn else))))) + (t `(if ,test ,then ,@(if else (macroexp-unprogn else)))))) (defmacro macroexp-let2 (test sym exp &rest body) "Evaluate BODY with SYM bound to an expression for EXP's value. @@ -480,6 +589,50 @@ itself or not." v (list 'quote v))) +(defun macroexp--fgrep (bindings sexp) + "Return those of the BINDINGS which might be used in SEXP. +It is used as a poor-man's \"free variables\" test. It differs from a true +test of free variables in the following ways: +- It does not distinguish variables from functions, so it can be used + both to detect whether a given variable is used by SEXP and to + detect whether a given function is used by SEXP. +- It does not actually know ELisp syntax, so it only looks for the presence + of symbols in SEXP and can't distinguish if those symbols are truly + references to the given variable (or function). That can make the result + include bindings which actually aren't used. +- For the same reason it may cause the result to fail to include bindings + which will be used if SEXP is not yet fully macro-expanded and the + use of the binding will only be revealed by macro expansion." + (let ((res '()) + ;; Cyclic code should not happen, but code can contain cyclic data :-( + (seen (make-hash-table :test #'eq)) + (sexpss (list (list sexp)))) + ;; Use a nested while loop to reduce the amount of heap allocations for + ;; pushes to `sexpss' and the `gethash' overhead. + (while (and sexpss bindings) + (let ((sexps (pop sexpss))) + (unless (gethash sexps seen) + (puthash sexps t seen) ;; Using `setf' here causes bootstrap problems. + (if (vectorp sexps) (setq sexps (mapcar #'identity sexps))) + (let ((tortoise sexps) (skip t)) + (while sexps + (let ((sexp (if (consp sexps) (pop sexps) + (prog1 sexps (setq sexps nil))))) + (if skip + (setq skip nil) + (setq tortoise (cdr tortoise)) + (if (eq tortoise sexps) + (setq sexps nil) ;; Found a cycle: we're done! + (setq skip t))) + (cond + ((or (consp sexp) (vectorp sexp)) (push sexp sexpss)) + (t + (let ((tmp (assq sexp bindings))) + (when tmp + (push tmp res) + (setq bindings (remove tmp bindings)))))))))))) + res)) + ;;; Load-time macro-expansion. ;; Because macro-expansion used to be more lazy, eager macro-expansion |