An anaphoric-macro-defining macro

Attention conservation notice: this post is about a special-purpose macro-defining macro. I doubt it will be of much interest to anyone but macro fans.

A year ago, Vladimir Sedach asked for arguments about why macros are and aren't useful. (He didn't get many; most of the people who can make such arguments are tired of doing so and not confident they're right.) In the same post, he mentioned that he uses the Anaphora macro library. Anaphora itself provides an example of how macros are useful, not only because it defines some handy ones, but because many of their definitions are repetitive:

(defmacro awhen (test &body body)
  "Like WHEN, except binds the result of the test to IT (via LET) for the scope
of the body."
  `(anaphoric when ,test ,@body))

(defmacro swhen (test &body body)
  "Like WHEN, except binds the test form to IT (via SYMBOL-MACROLET) for the
scope of the body. IT can be set with SETF."
  `(symbolic when ,test ,@body))

(defmacro acase (keyform &body cases)
  "Like CASE, except binds the result of the keyform to IT (via LET) for the
scope of the cases."
  `(anaphoric case ,keyform ,@cases))

(defmacro aetypecase (keyform &body cases)
  "Like ETYPECASE, except binds the result of the keyform to IT (via LET) for
the scope of the cases."
  `(anaphoric etypecase ,keyform ,@cases))

This is the sort of repetition that could be addressed with a macro. We can generate these definitions automatically, docstrings and all:

(defmacro defanaphoric (name (firstarg &rest moreargs) original &key settable)
  "Define NAME as a macro like ORIGINAL, but binding IT to the result of FIRSTARG.
If SETTABLE is true, IT will be a symbol-macro which can be set with SETF."
  (let ((whole (gensym "WHOLE")))
    `(defmacro ,name (&whole ,whole ,firstarg ,@moreargs)
       ,(format nil "Like ~S, except binds the result of ~S to IT (via ~S) for the scope of the ~A.~A"
          original
          firstarg
          (if settable 'let 'symbol-macrolet)
          (if (and moreargs (member (car moreargs) '(&body &rest))) (cadr moreargs) "body")
          (if settable " IT can be set with SETF." ""))
       ,@(mapcan (lambda (a) (unless (member a lambda-list-keywords)
                               `((declare (ignore ,a)))))
                 (cons firstarg moreargs))
       `(,',(if settable 'symbolic 'anaphoric) ,',original ,@(cdr ,whole)))))

Then it's easy to define individual anaphoric macros:

(defanaphoric awhen (test &body body) when)
(defanaphoric swhen (test &body body) when :symbolic t)
(defanaphoric acase (keyform &body cases) case)
(defanaphoric aetypecase (keyform &body cases) etypecase)

Note that almost half the code about generating docstrings. Anaphoric macros, like many other things, would be much simpler to define if they didn't need documentation.

The argument list (firstarg &rest moreargs) also exists purely for documentation purposes. We don't need it to define the macros — a simple &rest would do — but we need to pass it to defmacro so tools like SLIME and describe can display it. But repeating it as a parameter is ugly; it would be better to get the original's argument list automatically. There's no standard way to do this, but every implementation supports it; if we have a portability wrapper like swank-backend:arglist (or some non-Swank-dependent equivalent), we can do away with the explicit argument list:

(defmacro defanaphoric (name original &key settable)
  "Define NAME as a macro like ORIGINAL, but binding IT to the result of the first argument.
If SETTABLE is true, IT will be a symbol-macro which can be set with SETF."
  (let ((whole (gensym "WHOLE"))
        (arglist (swank-backend:arglist original)))
    `(defmacro ,name (&whole ,whole ,@arglist)
       ,(format nil "Like ~S, except binds the result of ~S to IT (via ~S) for the scope of the ~A.~A"
          original
          (car arglist)
          (if settable 'let 'symbol-macrolet)
          (if (and (cdr arglist) (member (cadr arglist) '(&body &rest)))
       (caddr arglist)
       "body")
          (if settable " IT can be set with SETF." ""))
       ,@(mapcan (lambda (a) (unless (member a lambda-list-keywords)
                               `((declare (ignore ,a)))))
                 arglist)
       `(,',(if settable 'symbolic 'anaphoric) ,',original ,@(cdr ,whole)))))

This makes the definitions of anaphoric macros transparently simple:

(defanaphoric awhen when)
(defanaphoric swhen when :settable t)
(defanaphoric acase case)
(defanaphoric aetypecase etypecase)

This might be useful for simplifying Anaphora, or even as a tool to expose to its users, but it's not much good as an answer to Vladimir's request for arguments for and against macros — macro-defining macros do not look useful to anyone who doesn't already think macros are useful.