defanaphoric.lisp

;; from the great http://arcanesentiment.blogspot.com/2011/08/anaphoric-macro-defining-macro.html

(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)))))


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