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