1 ;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock; -*-
5 ;;; mocking of generic methods and objects
7 (defun find-methods (methods)
8 (mapcar (lambda (method)
9 (destructuring-bind (generic-function qualifiers specializers) method
12 (find-method generic-function qualifiers specializers NIL))))
15 ;; TODO: because we use ENSURE-METHOD, each value is a FORM rather than a
16 ;; FUNCTION, so not quite the same as PROGF; judging by the implementation-
17 ;; specific code in CLOSER-MOP, we also can just create method objects
18 ;; ourselves reliably, so either we duplicate the cases or just use SBCL
20 (defun call-with-method-bindings* (methods values function
21 &optional (previous (find-methods methods)))
22 (mapc (lambda (previous)
23 (destructuring-bind (generic-function . method) previous
25 (remove-method generic-function method))))
28 (mapcar (lambda (method previous value)
29 (destructuring-bind (generic-function qualifiers specializers) method
30 (declare (ignore generic-function))
31 (destructuring-bind (generic-function . method) previous
35 (ensure-method generic-function value
36 :method-class (class-of method)
37 :qualifiers (method-qualifiers method)
38 :lambda-list (method-lambda-list method)
39 :specializers (method-specializers method))
40 (ensure-method generic-function value
41 :qualifiers qualifiers
42 :specializers specializers))))))
43 methods previous values)))
44 (unwind-protect (funcall function)
45 (mapc (lambda (new-method)
46 (destructuring-bind (generic-function . method) new-method
47 (remove-method generic-function method)))
49 (mapc (lambda (previous)
50 (destructuring-bind (generic-function . method) previous
52 (add-method generic-function method))))
55 (defmacro progm* (methods values &body body)
56 `(call-with-method-bindings* ,methods ,values (lambda () ,@body)))
58 (defun call-with-method-bindings (methods values function
61 (mapcar (lambda (method)
62 (destructuring-bind (generic-function qualifiers specializers) method
64 (if (functionp generic-function)
66 (fdefinition generic-function))
68 (mapcar (lambda (specializer)
69 (if (classp specializer)
71 (find-class specializer)))
74 (call-with-method-bindings* methods values function (or previous (find-methods methods)))))
76 (defmacro progm (methods values &body body)
77 `(call-with-method-bindings ,methods ,values (lambda () ,@body)))