-(defvar cl-macroexpand-cmacs nil)
-(defvar cl-closure-vars nil)
-
-;;;###autoload
-(defun cl-macroexpand-all (form &optional env)
- "Expand all macro calls through a Lisp FORM.
-This also does some trivial optimizations to make the form prettier."
- (while (or (not (eq form (setq form (macroexpand form env))))
- (and cl-macroexpand-cmacs
- (not (eq form (setq form (compiler-macroexpand form)))))))
- (cond ((not (consp form)) form)
- ((memq (car form) '(let let*))
- (if (null (nth 1 form))
- (cl-macroexpand-all (cons 'progn (cddr form)) env)
- (let ((letf nil) (res nil) (lets (cadr form)))
- (while lets
- (push (if (consp (car lets))
- (let ((exp (cl-macroexpand-all (caar lets) env)))
- (or (symbolp exp) (setq letf t))
- (cons exp (cl-macroexpand-body (cdar lets) env)))
- (let ((exp (cl-macroexpand-all (car lets) env)))
- (if (symbolp exp) exp
- (setq letf t) (list exp nil)))) res)
- (setq lets (cdr lets)))
- (list* (if letf (if (eq (car form) 'let) 'letf 'letf*) (car form))
- (nreverse res) (cl-macroexpand-body (cddr form) env)))))
- ((eq (car form) 'cond)
- (cons (car form)
- (mapcar (function (lambda (x) (cl-macroexpand-body x env)))
- (cdr form))))
- ((eq (car form) 'condition-case)
- (list* (car form) (nth 1 form) (cl-macroexpand-all (nth 2 form) env)
- (mapcar (function
- (lambda (x)
- (cons (car x) (cl-macroexpand-body (cdr x) env))))
- (cdddr form))))
- ((memq (car form) '(quote function))
- (if (eq (car-safe (nth 1 form)) 'lambda)
- (let ((body (cl-macroexpand-body (cddadr form) env)))
- (if (and cl-closure-vars (eq (car form) 'function)
- (cl-expr-contains-any body cl-closure-vars))
- (let* ((new (mapcar 'gensym cl-closure-vars))
- (sub (pairlis cl-closure-vars new)) (decls nil))
- (while (or (stringp (car body))
- (eq (car-safe (car body)) 'interactive))
- (push (list 'quote (pop body)) decls))
- (put (car (last cl-closure-vars)) 'used t)
- `(list 'lambda '(&rest --cl-rest--)
- ,@(sublis sub (nreverse decls))
- (list 'apply
- (list 'quote
- #'(lambda ,(append new (cadadr form))
- ,@(sublis sub body)))
- ,@(nconc (mapcar (lambda (x) `(list 'quote ,x))
- cl-closure-vars)
- '((quote --cl-rest--))))))
- (list (car form) (list* 'lambda (cadadr form) body))))
- (let ((found (assq (cadr form) env)))
- (if (and found (ignore-errors
- (eq (cadr (caddr found)) 'cl-labels-args)))
- (cl-macroexpand-all (cadr (caddr (cadddr found))) env)
- form))))
- ((memq (car form) '(defun defmacro))
- (list* (car form) (nth 1 form) (cl-macroexpand-body (cddr form) env)))
- ((and (eq (car form) 'progn) (not (cddr form)))
- (cl-macroexpand-all (nth 1 form) env))
- ((eq (car form) 'setq)
- (let* ((args (cl-macroexpand-body (cdr form) env)) (p args))
- (while (and p (symbolp (car p))) (setq p (cddr p)))
- (if p (cl-macroexpand-all (cons 'setf args)) (cons 'setq args))))
- ((consp (car form))
- (cl-macroexpand-all (list* 'funcall
- (list 'function (car form))
- (cdr form))
- env))
- (t (cons (car form) (cl-macroexpand-body (cdr form) env)))))
-
-(defun cl-macroexpand-body (body &optional env)
- (mapcar (function (lambda (x) (cl-macroexpand-all x env))) body))
-