compiler-macrolet.lisp

(define-symbol-macro +magic+ nil)

(defun %lexical-compiler-macros (&optional env)
  (macroexpand-1 '+magic+ env))

;;; proper declaration and llist parsing, gensyms, etc. left to the reader
(defmacro define-compiler-macro-shadowable (name lambda-list &body body)
  `(define-compiler-macro ,name (&whole form &environment env ,@lambda-list)
     (let ((local-macro-pair
             (assoc ',name (%lexical-compiler-macros env))))
       (if (null local-macro-pair)
           (progn ,@body)
           (funcall (cdr local-macro-pair) form env)))))

;;; parse-compiler-macro is also up to you.
;;; (it's slightly different to handle funcall forms.)
(defun parse-compiler-macrolet-bindings (bindings env)
  (loop for (name lambda-list . body) in bindings
        for expander
          = (sb-cltl2:enclose
             (sb-cltl2:parse-macro name lambda-list body env)
             env)
        collect (cons name expander)))

(defmacro compiler-macrolet ((&rest bindings) &body body &environment env)
  (let ((existing-macros (%lexical-compiler-macros env))
        (new-macros (parse-compiler-macrolet-bindings bindings env)))
    `(symbol-macrolet ((+magic+ (,@new-macros ,@existing-macros)))
       ,@body)))

;;;

(defun foo (x) x)

(define-compiler-macro-shadowable foo (x) (error "no global: ~a" x))
#|
=>
(DEFINE-COMPILER-MACRO FOO
    (&WHOLE FORM &ENVIRONMENT ENV X)
  (LET ((LOCAL-MACRO-PAIR (ASSOC 'FOO (%LEXICAL-COMPILER-MACROS ENV))))
    (IF (NULL LOCAL-MACRO-PAIR)
        (PROGN (ERROR "no global: ~a" X))
        (FUNCALL (CDR LOCAL-MACRO-PAIR) FORM ENV))))
|#

(defun bar (y)
  (compiler-macrolet ((foo (x) x))
    (foo y)))

#|
(SYMBOL-MACROLET ((+MAGIC+
                   ((FOO . #<FUNCTION (LAMBDA (#:EXPR #:ENV)) {52C74AAB}>))))
  (FOO Y))
|#