From: ········@ifistg.UUCP
Subject: Re: Common Lisp Macro Expander Wanted - (nf)
Date: Mon, 11 Apr 1988 10:24:43 +0000
Message-ID: <258@ifistg.UUCP>

Here are some functions to expand all macros in a lisp expression. I hope
this will help.

Andreas Girgensohn
·······························@uunet.uu.net

------------------------------- cut here -------------------------------

(defun macroexpand-all (form &optional env)
  (setq form (macroexpand form env))
  (if (atom form)
      form
      (case (car form)
	((catch if multiple-value-call multiple-value-prog1 progn progv
		setq tagbody throw unwind-protect)
	 (macroexpand-lambda-call form env))
	((declare go quote) form)
	((block eval-when return-from the)
	 (let ((body (macroexpand-body (cddr form) env)))
	   (if (eq body (cddr form)) form (list* (car form) (cadr form) body))))
	((flet labels macrolet) (macroexpand-flet form env))
	(function (let ((func (macroexpand-lambda (cadr form) env)))
		    (if (eq func (cadr form)) form (list (car form) func))))
	((compiler-let let let*) (macroexpand-let form env))
	(t (if (or (consp (car form))
		   (not (special-form-p (car form))))
	       (macroexpand-lambda-call form env)
	       form)))))			; unknown special form

(defun macroexpand-lambda-call (form env)
  (let ((func (macroexpand-lambda (car form) env))
	(args (macroexpand-body (cdr form) env)))
    (if (and (eq func (car form))
	     (eq args (cdr form)))
	form
	(cons func args))))

(defun macroexpand-lambda (func env)
  (if (atom func)
      func
      (let ((arglist (macroexpand-lambda-list (cadr func) env))
	    (body (macroexpand-body (cddr func) env)))
	(if (and (eq arglist (cadr func))
		 (eq body (cddr func)))
	    func
	    (list* (car func) arglist body)))))

(defun macroexpand-lambda-list (list env)
  env
  list)

(defun macroexpand-body (body env)
  (if (atom body)
      body
      (let ((first (macroexpand-all (car body) env))
	    (rest (macroexpand-body (cdr body) env)))
	(if (and (eq first (car body))
		 (eq rest (cdr body)))
	    body
	    (cons first rest)))))

(defun macroexpand-flet (form env)
  (let ((fdefs (macroexpand-flet-definitions (cadr form) env))
	(body (macroexpand-body (cddr form) env)))
    (if (and (eq fdefs (cadr form))
	     (eq body (cddr form)))
	form
	(list* (car form) fdefs body))))

(defun macroexpand-flet-definitions (defs env)
  (if (atom defs)
      defs
      (let ((first (macroexpand-lambda (car defs) env))
	    (rest (macroexpand-flet-definitions (cdr defs) env)))
	(if (and (eq first (car defs))
		 (eq rest (cdr defs)))
	    defs
	    (cons first rest)))))

(defun macroexpand-let (form env)
  (let ((bdgs (macroexpand-bindings (cadr form) env))
	(body (macroexpand-body (cddr form) env)))
    (if (and (eq bdgs (cadr form))
	     (eq body (cddr form)))
	form
	(list* (car form) bdgs body))))

(defun macroexpand-bindings (bdgs env)
  (if (atom bdgs)
      bdgs
      (let ((first (if (atom (car bdgs))
		       (car bdgs)
		       (let ((values (macroexpand-body (cdar bdgs) env)))
			 (if (eq values (cdar bdgs))
			     (car bdgs)
			     (cons (caar bdgs) values)))))
	    (rest (macroexpand-bindings (cdr bdgs) env)))
	(if (and (eq first (car bdgs))
		 (eq rest (cdr bdgs)))
	    bdgs
	    (cons first rest)))))