+++ /dev/null
-;; -*- 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)))