Poor man's defadvice

function-wrappers.lisp

;; Simple and rough substitute for defadvice :around on SBCL. Should
;; be easy to port by substituting something appropriate for
;; sb-introspect:function-lambda-list

;; Its easy to get confused with wrapped functions - if you redefine a
;; function while it is wrapped, it will still seem to be wrapped
;; (entry in the hash table for the name) but won't be.

(defvar *wrapped-functions* (make-hash-table))

(defun wrapped-function-p (function)
  (if (gethash function *wrapped-functions*) t nil))

(defmacro undefwrapper (function)
  (check-type function symbol)
  `(let ((orig-function (gethash ',function *wrapped-functions*)))
     (when orig-function
       (setf (fdefinition ',function) orig-function)
       (remhash ',function *wrapped-functions*))))

(defmacro defwrapper (function &body body)
  (labels ((copy (node)
             (etypecase node
               (symbol (intern (symbol-name node)))
               (atom node)
               (cons (cons (copy (car node))
                           (copy (cdr node)))))))
    (check-type function symbol)
    `(progn
       (assert (fboundp ',function))
       (assert (not (gethash ',function *wrapped-functions*)))
       (setf (gethash ',function *wrapped-functions*) #',function)
       (macrolet ((get-orig-function ()
                    `(gethash ',',function *wrapped-functions*))
                  (call-orig-function (&rest args)
                    `(apply (gethash ',',function *wrapped-functions*) (list ,@args))))
         (setf (fdefinition ',function)
               (lambda ,(copy (sb-introspect:function-lambda-list function))
                 ,@body))))))

;; (defun sum (values) (reduce #'+ values))

;; (sum '(1 3 5)) => 9

;; (defwrapper sum
;;   (let ((result (call-orig-function values)))
;;     (values result
;;             (/ result (length values)))))

;; (sum '(1 3 5)) => 9 3