contrib/sb-cltl2/macroexpand.lisp

   1 (in-package :sb-cltl2)
   2
   3 (defun macroexpand-all (form &optional environment)
   4   (let ((sb-walker::*walk-form-expand-macros-p* t))
   5     (sb-walker:walk-form
   6      form environment
   7      (lambda (subform context env)
   8        (acond ((and (eq context :eval)
   9                     (listp subform)
  10                     (symbolp (car subform))
  11                     (get (car subform) :partial-macroexpander))
  12                ;; The partial expander must return T as its second value
  13                ;; if it wants to stop the walk.
  14                (funcall it subform env))
  15               (t
  16                subform))))))
  17
  18 ;; Given EXPR, the argument to an invocation of Quasiquote macro, macroexpand
  19 ;; evaluable subforms of EXPR using ENV. A subform is evaluable if all
  20 ;; preceding occurrences of #\` have been "canceled" by a comma.
  21 ;; DEPTH counts the nesting and should not be supplied by external callers.
  22 (defun %quasiquoted-macroexpand-all (expr env &optional (depth 0))
  23   (flet ((quasiquote-p (x)
  24            (and (listp x) (eq (car x) 'quasiquote) (singleton-p (cdr x))))
  25          (recurse (x)
  26            (%quasiquoted-macroexpand-all x env depth)))
  27     (if (atom expr)
  28         (cond ((simple-vector-p expr) (map 'vector #'recurse expr))
  29               ((comma-p expr)
  30                (unquote (if (> depth 1)
  31                             (%quasiquoted-macroexpand-all
  32                              (comma-expr expr) env (1- depth))
  33                             (macroexpand-all (comma-expr expr) env))
  34                         (comma-kind expr)))
  35               (t expr))
  36         (if (quasiquote-p expr)
  37             (list 'quasiquote
  38                   (%quasiquoted-macroexpand-all (second expr) env (1+ depth)))
  39             (let (result)
  40               (loop
  41                (push (recurse (pop expr)) result)
  42                (when (or (atom expr) (quasiquote-p expr))
  43                  (return (nreconc result (recurse expr))))))))))
  44
  45 (setf (get 'quasiquote :partial-macroexpander)
  46       (lambda (form env)
  47         (destructuring-bind (arg) (cdr form) ; sanity-check the shape
  48           (declare (ignore arg))
  49           (values (%quasiquoted-macroexpand-all form env) t))))
  50
  51 #|
  52
  53 ;; Another example that some people might find useful.
  54
  55 (defun macroexpand-decls+forms (body env) ; a bit of a kludge, but it works
  56   (mapcar (lambda (x)
  57             (if (and (listp x) (eq (car x) 'declare))
  58                 x
  59                 (macroexpand-all x env)))
  60           body))
  61
  62 (setf (get 'dotimes :partial-macroexpander)
  63       (lambda (form env)
  64         (destructuring-bind ((var count &optional (result nil result-p))
  65                              &body body) (cdr form)
  66             (values `(dotimes (,var ,(macroexpand-all count env)
  67                                ,@(if result-p
  68                                      (list (macroexpand-all result env))))
  69                        ,@(macroexpand-decls+forms body env))
  70                     t))))
  71
  72 (macroexpand-all '(macrolet ((hair (x) `(car ,x)))
  73                    (dotimes (i (bar)) (foo i (hair baz)) l))))
  74 =>
  75 (MACROLET ((HAIR (X)
  76              `(CAR ,X)))
  77   (DOTIMES (I (BAR)) (FOO I (CAR BAZ)) L))
  78
  79 instead of
  80
  81 (MACROLET ((HAIR (X)
  82              `(CAR ,X)))
  83   (BLOCK NIL
  84     (LET ((I 0) (#:COUNT699 (BAR)))
  85       (DECLARE (TYPE UNSIGNED-BYTE I)
  86                (TYPE INTEGER #:COUNT699))
  87       (TAGBODY
  88         (GO #:G701)
  89        #:G700
  90         (TAGBODY (FOO I (CAR BAZ)) L)
  91         (LET* ()
  92           (MULTIPLE-VALUE-BIND (#:NEW702) (1+ I) (PROGN (SETQ I #:NEW702) NIL)))
  93        #:G701
  94         (IF (>= I #:COUNT699)
  95             NIL
  96             (PROGN (GO #:G700)))
  97         (RETURN-FROM NIL (PROGN NIL))))))
  98 |#