(defclass no-macro-expansion-walker-metaenv (agnostic-lizard:walker-metaenv) () (:documentation "A walker that performs no macro expansions. :ON-MACROEXPANDED-FORM is never called. For macro operators, only :ON-EVERY-FORM-PRE is called.")) (defmethod initialize-instance :after ((env no-macro-expansion-walker-metaenv) &key on-macroexpanded-form &allow-other-keys) (declare (ignore on-macroexpanded-form)) ;; TODO: We can't really signal a warning or an error when ;; ON-MACROEXPANDED-FORM is provided as it's regularly passed during cloning. ;; I guess this is just part of the interface of WALKER-METAENV and its ;; subclasses? ;; ;; (when on-macroexpanded-form ;; (warn "~s was specified but ~s doesn't perform any macro expansions" ;; 'on-macroexpanded-form 'no-macro-expansion-walker-metaenv)) ;; ;; Because we had to duplicate METAENV-MACROEXPAND-ALL's logic in order to ;; implement macro expansion inhibition, we don't need these wrapping handlers ;; below. :ON-MACROEXPANDED-FORM is simply never called. ;; (let ((last-form nil) ;; (old-on-every-form-pre ;; (agnostic-lizard::metaenv-on-every-form-pre env)) ;; (old-on-macroexpanded-form ;; (agnostic-lizard::metaenv-on-macroexpanded-form env))) ;; (setf (agnostic-lizard::metaenv-on-every-form-pre env) ;; (lambda (f e) ;; (setf last-form f) ;; (funcall old-on-every-form-pre f e)) ;; (agnostic-lizard::metaenv-on-macroexpanded-form env) ;; (lambda (f e) ;; (funcall old-on-macroexpanded-form f e) ;; last-form))) env) (defmethod print-object ((env no-macro-expansion-walker-metaenv) stream) (print-unreadable-object (env stream :type t :identity t))) (defmethod agnostic-lizard::metaenv-clone ((env no-macro-expansion-walker-metaenv) &optional overrides) (apply #'make-instance 'no-macro-expansion-walker-metaenv (append overrides (agnostic-lizard::metaenv-clone-args env)))) (defmethod agnostic-lizard:metaenv-macroexpand-all (form (env no-macro-expansion-walker-metaenv)) (let* ((replacement (funcall (agnostic-lizard::metaenv-on-every-form-pre env) form env)) (hardwiring-needed-p (and (consp replacement) (find (first replacement) agnostic-lizard::*hardwired-operators*))) (expanded-raw (if hardwiring-needed-p replacement (agnostic-lizard::metaenv-macroexpand replacement env))) (macrop (not (eq replacement expanded-raw)))) (if macrop replacement (let* ((function-like-p (and replacement (consp replacement))) (operator (and function-like-p (first replacement))) (specialp (and (symbolp operator) (special-operator-p operator))) (function-replacement (if (or specialp hardwiring-needed-p) (funcall (agnostic-lizard::metaenv-on-special-form-pre env) replacement env) (funcall (agnostic-lizard::metaenv-on-function-form-pre env) replacement env))) (full-expansion (cond ((not (eq function-replacement replacement)) (agnostic-lizard:metaenv-macroexpand-all function-replacement env)) ((not function-like-p) replacement) (specialp (agnostic-lizard::metaenv-macroexpand-all-special-form operator function-replacement env)) (t (agnostic-lizard::metaenv-macroexpand-all-special-form operator function-replacement env)))) (full-expansion-replacement (cond ((and function-like-p (not specialp) (not hardwiring-needed-p)) (funcall (agnostic-lizard::metaenv-on-function-form env) full-expansion env)) (function-like-p (funcall (agnostic-lizard::metaenv-on-special-form env) full-expansion env)) (t (funcall (agnostic-lizard::metaenv-on-every-atom env) full-expansion env)))) (result (funcall (agnostic-lizard::metaenv-on-every-form env) full-expansion-replacement env))) result)))) (defun walk-form-2 (form env &rest handler-definitions) (agnostic-lizard:metaenv-macroexpand-all form (apply #'make-instance (if env (class-of env) 'agnostic-lizard:walker-metaenv) (append handler-definitions (and env (agnostic-lizard::metaenv-clone-args env)))))) (defun test-walk-form-2 (form &optional env) (let ((count 0)) (macrolet ((p (msg) (let ((g!f (gensym (string 'f))) (g!env (gensym (string 'env)))) `(lambda (,g!f ,g!env) (declare (ignore ,g!env)) (incf count) (format t "~2,,,'0@s: ~s: ~s~%" count ,msg ,g!f) ,g!f)))) (my-walk-form form env :on-every-form-pre (p "on-every-form-pre") :on-every-form (p "on-every-form") :on-special-form-pre (p "on-special-form-pre") :on-special-form (p "on-special-form") :on-function-form-pre (p "on-function-form-pre") :on-function-form (p "on-function-form") :on-macroexpanded-form (p "on-macroexpanded-form") :on-every-atom (p "on-every-atom"))))) (defmacro with-overload-2 (specs &body body) (walk-form-2 `(progn ,@body) (make-instance 'no-macro-expansion-walker-metaenv) :on-function-form (lambda (f env) (declare (ignore env)) (if (consp f) (let ((rep (find (car f) specs :key #'first :test #'string-equal))) (if rep (cons (second rep) (cdr f)) f)) f))))