From a05f9c756098667b003c5326440a059748de884d Mon Sep 17 00:00:00 2001
From: Olof-Joachim Frahm <olof@macrolet.net>
Date: Tue, 23 Dec 2014 17:39:31 +0000
Subject: [PATCH] Re-add generic function stuff, fix symbols.

---
 cl-mock-basic.asd       |    1 +
 cl-mock-tests-basic.asd |    1 +
 src/methods.lisp        |   76 +++++++++++++++++++++++++++++++++++++++++++++++
 tests/methods.lisp      |   27 +++++++++++++++++
 4 files changed, 105 insertions(+)
 create mode 100644 src/methods.lisp
 create mode 100644 tests/methods.lisp

diff --git a/cl-mock-basic.asd b/cl-mock-basic.asd
index 03d3006..6c85273 100644
--- a/cl-mock-basic.asd
+++ b/cl-mock-basic.asd
@@ -20,4 +20,5 @@
                 :components
                 ((:file "package")
                  (:file "functions")
+                 (:file "methods")
                  (:file "mock")))))
diff --git a/cl-mock-tests-basic.asd b/cl-mock-tests-basic.asd
index 70cec0c..60a4f89 100644
--- a/cl-mock-tests-basic.asd
+++ b/cl-mock-tests-basic.asd
@@ -15,4 +15,5 @@
                 ((:file "package")
                  (:file "suite")
                  (:file "functions")
+                 (:file "methods")
                  (:file "mock")))))
diff --git a/src/methods.lisp b/src/methods.lisp
new file mode 100644
index 0000000..4688d2b
--- /dev/null
+++ b/src/methods.lisp
@@ -0,0 +1,76 @@
+;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock; -*-
+
+(in-package #:cl-mock)
+
+;;; 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)))
diff --git a/tests/methods.lisp b/tests/methods.lisp
new file mode 100644
index 0000000..f61be50
--- /dev/null
+++ b/tests/methods.lisp
@@ -0,0 +1,27 @@
+;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: cl-mock-tests; -*-
+
+(in-package #:cl-mock-tests)
+
+(in-suite cl-mock)
+
+(defclass foo ()
+  ())
+
+(defgeneric baz (foo)
+  (:method ((foo foo))
+    42))
+
+(def-test gf.simple ()
+  (cl-mock::progm
+      '((baz NIL (list)))
+      '((lambda (list) list))
+    (is (equal '(1 2 3) (baz '(1 2 3))))
+    (signals error (eq T (baz T)))
+    (is (eql 42 (baz (make-instance 'foo))))))
+
+(def-test gf.overwrite ()
+  (cl-mock::progm
+      '((baz NIL (foo)))
+      '((lambda (foo) 23))
+    (is (eql 23 (baz (make-instance 'foo)))))
+  (is (eql 42 (baz (make-instance 'foo)))))
-- 
1.7.10.4