Advertisement
Guest User

Untitled

a guest
Sep 19th, 2017
71
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 1.11 KB | None | 0 0
  1. (defmacro with-replaced-function (fdef &rest body)
  2. (let ((oldf (gensym))
  3. (result (gensym))
  4. (name (car fdef))
  5. (args (cadr fdef))
  6. (rbody (cddr fdef)))
  7. `(let ((,oldf (symbol-function ',name)))
  8. (setf (symbol-function ',name) (lambda ,args ,@rbody))
  9. (let ((,result (progn ,@body)))
  10. (setf (symbol-function ',name) ,oldf)
  11. ,result))))
  12.  
  13. (defmacro show (x)
  14. `(format t "~a --> ~a~%"
  15. ',x ,x))
  16.  
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18.  
  19. (defun foo (x y) (+ x y))
  20.  
  21. (defun bar (x) (foo x (* x 2)))
  22.  
  23. (show (bar 42))
  24.  
  25. (show (with-replaced-function (foo (x y) (* x y))
  26. (bar 42)))
  27.  
  28. (show (bar 42))
  29.  
  30. > (defun b () 'original)
  31. B
  32. > (setf f #'b)
  33. #<Compiled-function B #xC2C1546>
  34. > (defun a () (funcall f))
  35. A
  36. > (a)
  37. ORIGINAL
  38. > (setf f #'(lambda () 'stub))
  39. #<Anonymous Function #xC2D990E>
  40. > (a)
  41. STUB
  42. > (setf f #'b)
  43. #<Compiled-function B #xC2C1546>
  44. > (a)
  45. ORIGINAL
  46.  
  47. (defmacro with-fun (origfn mockfn &body body)
  48. `(let ((it ,origfn))
  49. (setf ,origfn ,mockfn)
  50. ,@body
  51. (setf ,origfn ,it)))
  52.  
  53. (ql:quickload :mockingbird)
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement