(defvar macroexpand-all-environment nil)
(defun maybe-cons (car cdr original-cons)
"Return (CAR . CDR), using ORIGINAL-CONS if possible."
(if (and (eq car (car original-cons)) (eq cdr (cdr original-cons)))
original-cons
(cons car cdr)))
(defmacro macroexp-accumulate (var+list &rest body)
"Return a list of the results of evaluating BODY for each element of LIST.
Evaluate BODY with VAR bound to each `car' from LIST, in turn.
Return a list of the values of the final form in BODY.
The list structure of the result will share as much with LIST as
possible (for instance, when BODY just returns VAR unchanged, the
result will be eq to LIST).
\(fn (VAR LIST) BODY...)"
(let ((var (car var+list))
(list (cadr var+list))
(shared (make-symbol "shared"))
(unshared (make-symbol "unshared"))
(tail (make-symbol "tail"))
(new-el (make-symbol "new-el")))
`(let* ((,shared ,list)
(,unshared nil)
(,tail ,shared)
,var ,new-el)
(while ,tail
(setq ,var (car ,tail)
,new-el (progn ,@body))
(unless (eq ,var ,new-el)
(while (not (eq ,shared ,tail))
(push (pop ,shared) ,unshared))
(setq ,shared (cdr ,shared))
(push ,new-el ,unshared))
(setq ,tail (cdr ,tail)))
(nconc (nreverse ,unshared) ,shared))))
(put 'macroexp-accumulate 'lisp-indent-function 1)
(defun macroexpand-all-forms (forms &optional skip)
"Return FORMS with macros expanded. FORMS is a list of forms.
If SKIP is non-nil, then don't expand that many elements at the start of
FORMS."
(macroexp-accumulate (form forms)
(if (or (null skip) (zerop skip))
(macroexpand-all-1 form)
(setq skip (1- skip))
form)))
(defun macroexpand-all-clauses (clauses &optional skip)
"Return CLAUSES with macros expanded.
CLAUSES is a list of lists of forms; any clause that's not a list is ignored.
If SKIP is non-nil, then don't expand that many elements at the start of
each clause."
(macroexp-accumulate (clause clauses)
(if (listp clause)
(macroexpand-all-forms clause skip)
clause)))
(defun macroexpand-all-1 (form)
"Expand all macros in FORM.
This is an internal version of `macroexpand-all'.
Assumes the caller has bound `macroexpand-all-environment'."
(if (and (listp form) (eq (car form) 'backquote-list*))
(macroexpand (macroexpand-all-forms form 1)
macroexpand-all-environment)
(setq form (macroexpand form macroexpand-all-environment))
(if (consp form)
(let ((fun (car form)))
(cond
((eq fun 'cond)
(maybe-cons fun (macroexpand-all-clauses (cdr form)) form))
((eq fun 'condition-case)
(maybe-cons
fun
(maybe-cons (cadr form)
(maybe-cons (macroexpand-all-1 (nth 2 form))
(macroexpand-all-clauses (nthcdr 3 form) 1)
(cddr form))
(cdr form))
form))
((eq fun 'defmacro)
(push (cons (cadr form) (cons 'lambda (cddr form)))
macroexpand-all-environment)
(macroexpand-all-forms form 3))
((eq fun 'defun)
(macroexpand-all-forms form 3))
((memq fun '(defvar defconst))
(macroexpand-all-forms form 2))
((eq fun 'function)
(if (and (consp (cadr form)) (eq (car (cadr form)) 'lambda))
(maybe-cons fun
(maybe-cons (macroexpand-all-forms (cadr form) 2)
nil
(cadr form))
form)
form))
((memq fun '(let let*))
(maybe-cons fun
(maybe-cons (macroexpand-all-clauses (cadr form) 1)
(macroexpand-all-forms (cddr form))
(cdr form))
form))
((eq fun 'quote)
form)
((and (consp fun) (eq (car fun) 'lambda))
(maybe-cons (macroexpand-all-forms fun 2)
(macroexpand-all-forms (cdr form))
form))
((and (memq fun '(apply mapcar mapatoms mapconcat mapc))
(consp (cadr form))
(eq (car (cadr form)) 'quote))
(cons fun
(cons (macroexpand-all-1 (cons 'function (cdr (cadr form))))
(macroexpand-all-forms (cddr form)))))
((and (eq fun 'sort)
(consp (nth 2 form))
(eq (car (nth 2 form)) 'quote))
(cons fun
(cons (macroexpand-all-1 (cadr form))
(cons (macroexpand-all-1
(cons 'function (cdr (nth 2 form))))
(macroexpand-all-forms (nthcdr 3 form))))))
(t
(macroexpand-all-forms form 1))))
form)))
(defun macroexpand-all (form &optional environment)
"Return result of expanding macros at all levels in FORM.
If no macros are expanded, FORM is returned unchanged.
The second optional arg ENVIRONMENT specifies an environment of macro
definitions to shadow the loaded ones for use in file byte-compilation."
(let ((macroexpand-all-environment environment))
(macroexpand-all-1 form)))
(provide 'macroexp)