+;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock; -*-
+
+(in-package #:cl-mock)
+\f
+;;; mocking of generic methods and objects
+
+(defun find-methods (methods)
+ (mapcar (lambda (method)
+ (destructuring-bind (generic-function qualifiers specializers) method
+ (cons
+ generic-function
+ (find-method generic-function qualifiers specializers NIL))))
+ methods))
+
+;; TODO: because we use ENSURE-METHOD, each value is a FORM rather than a
+;; FUNCTION, so not quite the same as PROGF; judging by the implementation-
+;; specific code in CLOSER-MOP, we also can just create method objects
+;; ourselves reliably, so either we duplicate the cases or just use SBCL
+
+(defun call-with-method-bindings* (methods values function
+ &optional (previous (find-methods methods)))
+ (mapc (lambda (previous)
+ (destructuring-bind (generic-function . method) previous
+ (when method
+ (remove-method generic-function method))))
+ previous)
+ (let ((new-methods
+ (mapcar (lambda (method previous value)
+ (destructuring-bind (generic-function qualifiers specializers) method
+ (declare (ignore generic-function))
+ (destructuring-bind (generic-function . method) previous
+ (cons
+ generic-function
+ (if method
+ (ensure-method generic-function value
+ :method-class (class-of method)
+ :qualifiers (method-qualifiers method)
+ :lambda-list (method-lambda-list method)
+ :specializers (method-specializers method))
+ (ensure-method generic-function value
+ :qualifiers qualifiers
+ :specializers specializers))))))
+ methods previous values)))
+ (unwind-protect (funcall function)
+ (mapc (lambda (new-method)
+ (destructuring-bind (generic-function . method) new-method
+ (remove-method generic-function method)))
+ new-methods)
+ (mapc (lambda (previous)
+ (destructuring-bind (generic-function . method) previous
+ (when method
+ (add-method generic-function method))))
+ previous))))
+
+(defmacro progm* (methods values &body body)
+ `(call-with-method-bindings* ,methods ,values (lambda () ,@body)))
+
+(defun classify (specializer)
+ (if (classp specializer)
+ specializer
+ (find-class specializer)))
+
+(defun call-with-method-bindings (methods values function
+ &optional previous)
+ (let ((methods
+ (mapcar (lambda (method)
+ (destructuring-bind (generic-function qualifiers specializers) method
+ (list
+ (ensure-function generic-function)
+ qualifiers
+ (mapcar #'classify specializers))))
+ methods)))
+ (call-with-method-bindings* methods values function (or previous (find-methods methods)))))
+
+(defmacro progm (methods values &body body)
+ `(call-with-method-bindings ,methods ,values (lambda () ,@body)))