call-next-macro
Here's a macro example that may be less of a headache to understand than rebinding. It provides a way for a local macro definition to defer to the "next" macro definition under the same name. In this context, "next" means the lexically exterior definition, or else the global definition, if there is one (obtained via macro-function). This is by analogy with call-next-method and next-method-p in method definitions.

(eval-when (:compile-toplevel :load-toplevel :execute) (defun get-macro (name macro-functions &optional errorp) (let ((macro-function (cdr (assoc name macro-functions)))) (when macro-function (return-from get-macro macro-function)) (when errorp (error "No macro definition for ~S." name))))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun macro-lambda-list (lambda-list whole env) "Ensure &whole and &environment in LAMBDA-LIST." (when (eq (first lambda-list) '&whole) (setq whole (second lambda-list)) (setq lambda-list (cddr lambda-list))) (loop with env-p = nil for (element . tail) on lambda-list when (eq element '&environment) do (setq env-p t env (car tail)) finally (unless env-p (setq lambda-list (list* '&environment env lambda-list))) (setq lambda-list (list* '&whole whole lambda-list)) (return (values lambda-list whole env))))) (defmacro macrolet+ ((&rest macro-definitions) &body body &environment environment) (loop with whole = (gensym (string 'whole)) and env = (gensym (string 'environment)) for (name lambda-list . macro-body) in macro-definitions for macro-function = (macro-function name environment) collect (cons name macro-function) into old-macro-functions collect (multiple-value-bind (lambda-list whole env) (macro-lambda-list lambda-list whole env) `(,name ,lambda-list (flet ((next-macro-p () "Return true if there is a next macro." (get-macro ',name ',old-macro-functions)) (call-next-macro (&rest macro-arguments &aux (,whole ,whole)) "Call the next (outer) MACRO-FUNCTION, or else signal an error." (when macro-arguments (setq ,whole (list* ',name macro-arguments))) (let ((next-macro (get-macro ',name ',old-macro-functions t))) (funcall *macroexpand-hook* next-macro ,whole ,env)))) (declare (dynamic-extent #'next-macro-p)) (declare (dynamic-extent #'call-next-macro)) ,@macro-body))) into new-macro-definitions ;; Now each macro definition can use CALL-NEXT-MACRO. finally (return `(macrolet ,new-macro-definitions ,@body))))

Quick example

(macrolet+ ((foo (x) (if (numberp x) "It's a number." (call-next-macro)))) (macrolet+ ((foo (x) (if (eql x 7) "Lucky." (call-next-macro)))) (values (foo 12) (foo 13) (foo 1234567890) (foo 7))))

Evaluating the above gives the values:

"It's a number." "It's a number." "It's a number." "Lucky."

The first three macro calls (corresponding to the inner definition) invoked call-next-macro, while the last one didn't.

(macrolet+ ((foo (x) (if (numberp x) "It's a number." (call-next-macro)))) (macrolet+ ((foo (x) (if (eql x 7) "Lucky." (call-next-macro)))) (values (foo 12) (foo 13) (foo 1234567890) (foo not-a-number))))

This signals an error:

> Error: No macro definition for FOO.
> While executing: GET-MACRO, in process listener(1).
> Type :POP to abort, :R for a list of available restarts.
> Type :? for other options.

In other words, there isn't any global definition of the foo macro. Availability can be checked with next-macro-p.

Another example

This is a vaguely loop-like collecting facility:

(defmacro collecting ((initial-list &rest remaining-lists) &body body) (let* ((tail-name-parts (mapcar #'symbol-name (list initial-list '#:tail))) (initial-tail (gensym (apply #'format nil "~A-~A" tail-name-parts)))) `(let (,initial-list ,initial-tail) (macrolet+ ((collect (item &key into) (if (eq into ',initial-list) `(if ,',initial-tail (progn (setf (cdr ,',initial-tail) (list ,item)) (setq ,',initial-tail (cdr ,',initial-tail))) (setq ,',initial-tail (push ,item ,',initial-list))) (call-next-macro)))) ;; Handle the REMAINING-LISTS, if any. ,@(cond ((endp remaining-lists) body) (t `((collecting ,remaining-lists ,@body))))))))

Used like this:

? (collecting (odds evens) (dotimes (n 20 (values odds evens)) (if (oddp n) (collect n :into odds) (collect n :into evens)))) (1 3 5 7 9 11 13 15 17 19) (0 2 4 6 8 10 12 14 16 18)

Known problems

Related reading

Public Domain