From: Olof-Joachim Frahm Date: Tue, 23 Dec 2014 17:39:31 +0000 (+0000) Subject: Re-add generic function stuff, fix symbols. X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a05f9c756098667b003c5326440a059748de884d;p=cl-mock.git Re-add generic function stuff, fix symbols. --- 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)))))