Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- ;; 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
Add Comment
Please, Sign In to add comment