configure.ac whitespace trivia
[emacs.git] / lisp / emacs-lisp / macroexp.el
blob70eab14983738e8356d08007b66d0d398c43f412
1 ;;; macroexp.el --- Additional macro-expansion support -*- lexical-binding: t; coding: utf-8 -*-
2 ;;
3 ;; Copyright (C) 2004-2012 Free Software Foundation, Inc.
4 ;;
5 ;; Author: Miles Bader <miles@gnu.org>
6 ;; Keywords: lisp, compiler, macros
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23 ;;; Commentary:
25 ;; This file contains macro-expansions functions that are not defined in
26 ;; the Lisp core, namely `macroexpand-all', which expands all macros in
27 ;; a form, not just a top-level one.
30 ;;; Code:
32 ;; Bound by the top-level `macroexpand-all', and modified to include any
33 ;; macros defined by `defmacro'.
34 (defvar macroexpand-all-environment nil)
36 (defun macroexp--cons (car cdr original-cons)
37 "Return (CAR . CDR), using ORIGINAL-CONS if possible."
38 (if (and (eq car (car original-cons)) (eq cdr (cdr original-cons)))
39 original-cons
40 (cons car cdr)))
42 ;; We use this special macro to iteratively process forms and share list
43 ;; structure of the result with the input. Doing so recursively using
44 ;; `macroexp--cons' results in excessively deep recursion for very long
45 ;; input forms.
46 (defmacro macroexp--accumulate (var+list &rest body)
47 "Return a list of the results of evaluating BODY for each element of LIST.
48 Evaluate BODY with VAR bound to each `car' from LIST, in turn.
49 Return a list of the values of the final form in BODY.
50 The list structure of the result will share as much with LIST as
51 possible (for instance, when BODY just returns VAR unchanged, the
52 result will be eq to LIST).
54 \(fn (VAR LIST) BODY...)"
55 (declare (indent 1))
56 (let ((var (car var+list))
57 (list (cadr var+list))
58 (shared (make-symbol "shared"))
59 (unshared (make-symbol "unshared"))
60 (tail (make-symbol "tail"))
61 (new-el (make-symbol "new-el")))
62 `(let* ((,shared ,list)
63 (,unshared nil)
64 (,tail ,shared)
65 ,var ,new-el)
66 (while (consp ,tail)
67 (setq ,var (car ,tail)
68 ,new-el (progn ,@body))
69 (unless (eq ,var ,new-el)
70 (while (not (eq ,shared ,tail))
71 (push (pop ,shared) ,unshared))
72 (setq ,shared (cdr ,shared))
73 (push ,new-el ,unshared))
74 (setq ,tail (cdr ,tail)))
75 (nconc (nreverse ,unshared) ,shared))))
77 (defun macroexp--all-forms (forms &optional skip)
78 "Return FORMS with macros expanded. FORMS is a list of forms.
79 If SKIP is non-nil, then don't expand that many elements at the start of
80 FORMS."
81 (macroexp--accumulate (form forms)
82 (if (or (null skip) (zerop skip))
83 (macroexp--expand-all form)
84 (setq skip (1- skip))
85 form)))
87 (defun macroexp--all-clauses (clauses &optional skip)
88 "Return CLAUSES with macros expanded.
89 CLAUSES is a list of lists of forms; any clause that's not a list is ignored.
90 If SKIP is non-nil, then don't expand that many elements at the start of
91 each clause."
92 (macroexp--accumulate (clause clauses)
93 (if (listp clause)
94 (macroexp--all-forms clause skip)
95 clause)))
97 (defun macroexp--compiler-macro (handler form)
98 (condition-case err
99 (apply handler form (cdr form))
100 (error (message "Compiler-macro error for %S: %S" (car form) err)
101 form)))
103 (defun macroexp--expand-all (form)
104 "Expand all macros in FORM.
105 This is an internal version of `macroexpand-all'.
106 Assumes the caller has bound `macroexpand-all-environment'."
107 (if (and (listp form) (eq (car form) 'backquote-list*))
108 ;; Special-case `backquote-list*', as it is normally a macro that
109 ;; generates exceedingly deep expansions from relatively shallow input
110 ;; forms. We just process it `in reverse' -- first we expand all the
111 ;; arguments, _then_ we expand the top-level definition.
112 (macroexpand (macroexp--all-forms form 1)
113 macroexpand-all-environment)
114 ;; Normal form; get its expansion, and then expand arguments.
115 (let ((new-form (macroexpand form macroexpand-all-environment)))
116 (when (and (not (eq form new-form)) ;It was a macro call.
117 (car-safe form)
118 (symbolp (car form))
119 (get (car form) 'byte-obsolete-info)
120 (fboundp 'byte-compile-warn-obsolete))
121 (byte-compile-warn-obsolete (car form)))
122 (setq form new-form))
123 (pcase form
124 (`(cond . ,clauses)
125 (macroexp--cons 'cond (macroexp--all-clauses clauses) form))
126 (`(condition-case . ,(or `(,err ,body . ,handlers) dontcare))
127 (macroexp--cons
128 'condition-case
129 (macroexp--cons err
130 (macroexp--cons (macroexp--expand-all body)
131 (macroexp--all-clauses handlers 1)
132 (cddr form))
133 (cdr form))
134 form))
135 (`(,(or `defvar `defconst) . ,_) (macroexp--all-forms form 2))
136 (`(function ,(and f `(lambda . ,_)))
137 (macroexp--cons 'function
138 (macroexp--cons (macroexp--all-forms f 2)
140 (cdr form))
141 form))
142 (`(,(or `function `quote) . ,_) form)
143 (`(,(and fun (or `let `let*)) . ,(or `(,bindings . ,body) dontcare))
144 (macroexp--cons fun
145 (macroexp--cons (macroexp--all-clauses bindings 1)
146 (macroexp--all-forms body)
147 (cdr form))
148 form))
149 (`(,(and fun `(lambda . ,_)) . ,args)
150 ;; Embedded lambda in function position.
151 (macroexp--cons (macroexp--all-forms fun 2)
152 (macroexp--all-forms args)
153 form))
154 ;; The following few cases are for normal function calls that
155 ;; are known to funcall one of their arguments. The byte
156 ;; compiler has traditionally handled these functions specially
157 ;; by treating a lambda expression quoted by `quote' as if it
158 ;; were quoted by `function'. We make the same transformation
159 ;; here, so that any code that cares about the difference will
160 ;; see the same transformation.
161 ;; First arg is a function:
162 (`(,(and fun (or `funcall `apply `mapcar `mapatoms `mapconcat `mapc))
163 ',(and f `(lambda . ,_)) . ,args)
164 (byte-compile-log-warning
165 (format "%s quoted with ' rather than with #'"
166 (list 'lambda (nth 1 f) '...))
168 ;; We don't use `macroexp--cons' since there's clearly a change.
169 (cons fun
170 (cons (macroexp--expand-all (list 'function f))
171 (macroexp--all-forms args))))
172 ;; Second arg is a function:
173 (`(,(and fun (or `sort)) ,arg1 ',(and f `(lambda . ,_)) . ,args)
174 (byte-compile-log-warning
175 (format "%s quoted with ' rather than with #'"
176 (list 'lambda (nth 1 f) '...))
178 ;; We don't use `macroexp--cons' since there's clearly a change.
179 (cons fun
180 (cons (macroexp--expand-all arg1)
181 (cons (macroexp--expand-all
182 (list 'function f))
183 (macroexp--all-forms args)))))
184 (`(,func . ,_)
185 ;; Macro expand compiler macros. This cannot be delayed to
186 ;; byte-optimize-form because the output of the compiler-macro can
187 ;; use macros.
188 (let ((handler (function-get func 'compiler-macro)))
189 (if (null handler)
190 ;; No compiler macro. We just expand each argument (for
191 ;; setq/setq-default this works alright because the variable names
192 ;; are symbols).
193 (macroexp--all-forms form 1)
194 ;; If the handler is not loaded yet, try (auto)loading the
195 ;; function itself, which may in turn load the handler.
196 (unless (functionp handler)
197 (ignore-errors
198 (autoload-do-load (indirect-function func) func)))
199 (let ((newform (macroexp--compiler-macro handler form)))
200 (if (eq form newform)
201 ;; The compiler macro did not find anything to do.
202 (if (equal form (setq newform (macroexp--all-forms form 1)))
203 form
204 ;; Maybe after processing the args, some new opportunities
205 ;; appeared, so let's try the compiler macro again.
206 (setq form (macroexp--compiler-macro handler newform))
207 (if (eq newform form)
208 newform
209 (macroexp--expand-all newform)))
210 (macroexp--expand-all newform))))))
212 (t form))))
214 ;;;###autoload
215 (defun macroexpand-all (form &optional environment)
216 "Return result of expanding macros at all levels in FORM.
217 If no macros are expanded, FORM is returned unchanged.
218 The second optional arg ENVIRONMENT specifies an environment of macro
219 definitions to shadow the loaded ones for use in file byte-compilation."
220 (let ((macroexpand-all-environment environment))
221 (macroexp--expand-all form)))
223 ;;; Handy functions to use in macros.
225 (defun macroexp-progn (exps)
226 "Return an expression equivalent to `(progn ,@EXPS)."
227 (if (cdr exps) `(progn ,@exps) (car exps)))
229 (defun macroexp-unprogn (exp)
230 "Turn EXP into a list of expressions to execute in sequence."
231 (if (eq (car-safe exp) 'progn) (cdr exp) (list exp)))
233 (defun macroexp-let* (bindings exp)
234 "Return an expression equivalent to `(let* ,bindings ,exp)."
235 (cond
236 ((null bindings) exp)
237 ((eq 'let* (car-safe exp)) `(let* (,@bindings ,@(cadr exp)) ,@(cddr exp)))
238 (t `(let* ,bindings ,exp))))
240 (defun macroexp-if (test then else)
241 "Return an expression equivalent to `(if ,test ,then ,else)."
242 (cond
243 ((eq (car-safe else) 'if)
244 (if (equal test (nth 1 else))
245 ;; Doing a test a second time: get rid of the redundancy.
246 `(if ,test ,then ,@(nthcdr 3 else))
247 `(cond (,test ,then)
248 (,(nth 1 else) ,(nth 2 else))
249 (t ,@(nthcdr 3 else)))))
250 ((eq (car-safe else) 'cond)
251 `(cond (,test ,then)
252 ;; Doing a test a second time: get rid of the redundancy, as above.
253 ,@(remove (assoc test else) (cdr else))))
254 ;; Invert the test if that lets us reduce the depth of the tree.
255 ((memq (car-safe then) '(if cond)) (macroexp-if `(not ,test) else then))
256 (t `(if ,test ,then ,else))))
258 (defmacro macroexp-let2 (test var exp &rest exps)
259 "Bind VAR to a copyable expression that returns the value of EXP.
260 This is like `(let ((v ,EXP)) ,EXPS) except that `v' is a new generated
261 symbol which EXPS can find in VAR.
262 TEST should be the name of a predicate on EXP checking whether the `let' can
263 be skipped; if nil, as is usual, `macroexp-const-p' is used."
264 (declare (indent 3) (debug (sexp sexp form body)))
265 (let ((bodysym (make-symbol "body"))
266 (expsym (make-symbol "exp")))
267 `(let* ((,expsym ,exp)
268 (,var (if (funcall #',(or test #'macroexp-const-p) ,expsym)
269 ,expsym (make-symbol ,(symbol-name var))))
270 (,bodysym ,(macroexp-progn exps)))
271 (if (eq ,var ,expsym) ,bodysym
272 (macroexp-let* (list (list ,var ,expsym))
273 ,bodysym)))))
275 (defun macroexp--maxsize (exp size)
276 (cond ((< size 0) size)
277 ((symbolp exp) (1- size))
278 ((stringp exp) (- size (/ (length exp) 16)))
279 ((vectorp exp)
280 (dotimes (i (length exp))
281 (setq size (macroexp--maxsize (aref exp i) size)))
282 (1- size))
283 ((consp exp)
284 ;; We could try to be more clever with quote&function,
285 ;; but it is difficult to do so correctly, and it's not obvious that
286 ;; it would be worth the effort.
287 (dolist (e exp)
288 (setq size (macroexp--maxsize e size)))
289 (1- size))
290 (t -1)))
292 (defun macroexp-small-p (exp)
293 "Return non-nil if EXP can be considered small."
294 (> (macroexp--maxsize exp 10) 0))
296 (defsubst macroexp--const-symbol-p (symbol &optional any-value)
297 "Non-nil if SYMBOL is constant.
298 If ANY-VALUE is nil, only return non-nil if the value of the symbol is the
299 symbol itself."
300 (or (memq symbol '(nil t))
301 (keywordp symbol)
302 (if any-value
303 (or (memq symbol byte-compile-const-variables)
304 ;; FIXME: We should provide a less intrusive way to find out
305 ;; if a variable is "constant".
306 (and (boundp symbol)
307 (condition-case nil
308 (progn (set symbol (symbol-value symbol)) nil)
309 (setting-constant t)))))))
311 (defun macroexp-const-p (exp)
312 "Return non-nil if EXP will always evaluate to the same value."
313 (cond ((consp exp) (or (eq (car exp) 'quote)
314 (and (eq (car exp) 'function)
315 (symbolp (cadr exp)))))
316 ;; It would sometimes make sense to pass `any-value', but it's not
317 ;; always safe since a "constant" variable may not actually always have
318 ;; the same value.
319 ((symbolp exp) (macroexp--const-symbol-p exp))
320 (t t)))
322 (defun macroexp-copyable-p (exp)
323 "Return non-nil if EXP can be copied without extra cost."
324 (or (symbolp exp) (macroexp-const-p exp)))
326 (provide 'macroexp)
328 ;;; macroexp.el ends here