src/methods.lisp

   1 ;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock; -*-
   2
   3 (in-package #:cl-mock)
   4 \f
   5 ;;; mocking of generic methods and objects
   6
   7 (defun find-methods (methods)
   8   (mapcar (lambda (method)
   9             (destructuring-bind (generic-function qualifiers specializers) method
  10               (cons
  11                generic-function
  12                (find-method generic-function qualifiers specializers NIL))))
  13           methods))
  14
  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
  19
  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
  24             (when method
  25               (remove-method generic-function method))))
  26         previous)
  27   (let ((new-methods
  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
  32                         (cons
  33                          generic-function
  34                          (if method
  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)))
  48             new-methods)
  49       (mapc (lambda (previous)
  50               (destructuring-bind (generic-function . method) previous
  51                 (when method
  52                   (add-method generic-function method))))
  53             previous))))
  54
  55 (defmacro progm* (methods values &body body)
  56   `(call-with-method-bindings* ,methods ,values (lambda () ,@body)))
  57
  58 (defun classify (specializer)
  59   (if (classp specializer)
  60       specializer
  61       (find-class specializer)))
  62
  63 (defun call-with-method-bindings (methods values function
  64                                   &optional previous)
  65   (let ((methods
  66           (mapcar (lambda (method)
  67                     (destructuring-bind (generic-function qualifiers specializers) method
  68                       (list
  69                        (ensure-function generic-function)
  70                        qualifiers
  71                        (mapcar #'classify specializers))))
  72                   methods)))
  73     (call-with-method-bindings* methods values function (or previous (find-methods methods)))))
  74
  75 (defmacro progm (methods values &body body)
  76   `(call-with-method-bindings ,methods ,values (lambda () ,@body)))