tests/mop-34.impure.lisp

   1 ;;;; Ensuring that COMPUTE-EFFECTIVE-METHOD is usable
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (defclass foo-generic-function (standard-generic-function)
  15   ()
  16   (:metaclass sb-mop:funcallable-standard-class))
  17
  18 (defclass made-method (method)
  19   ((function :initarg :function :reader sb-mop:method-function)))
  20
  21 (defun make-made-method (form)
  22   (let ((fun `(lambda (args next-methods)
  23                 (declare (sb-ext:disable-package-locks call-method))
  24                 (macrolet ((call-method (m nexts)
  25                              (flet ((make-next (next)
  26                                       (etypecase next
  27                                         (method next)
  28                                         ((cons (eql make-method)) (make-made-method (cadr next))))))
  29                                `(funcall (sb-mop:method-function ,m) args ',(mapcar #'make-next nexts)))))
  30                   (declare (sb-ext:enable-package-locks call-method))
  31                   (declare (sb-ext:disable-package-locks call-next-method next-method-p))
  32                   (flet ((next-method-p () (not (null next-methods)))
  33                          (call-next-method (&rest args)
  34                            (let ((next (car next-methods)))
  35                              (if next
  36                                  (funcall next args (cdr next-methods))
  37                                  (error "no next method")))))
  38                     (declare (ignorable #'next-method-p #'call-next-method))
  39                     (declare (sb-ext:enable-package-locks call-next-method next-method-p))
  40                     ,form)))))
  41     (make-instance 'made-method :function (compile nil fun))))
  42
  43 (defmethod sb-mop:compute-discriminating-function ((gf foo-generic-function))
  44   (let* ((apo (sb-mop:generic-function-argument-precedence-order gf))
  45          (nreq (length apo))
  46          (combin (sb-mop:generic-function-method-combination gf)))
  47     (lambda (&rest args)
  48       (let* ((methods (sb-mop:compute-applicable-methods gf (subseq args 0 nreq)))
  49              (effective-method (sb-mop:compute-effective-method gf combin methods)))
  50         (let ((fun (compile nil `(lambda (args)
  51                                    (declare (sb-ext:disable-package-locks call-method))
  52                                    (macrolet ((call-method (m nexts)
  53                                                 (flet ((make-next (next)
  54                                                          (etypecase next
  55                                                            (method next)
  56                                                            ((cons (eql make-method)) (make-made-method (cadr next))))))
  57                                                   `(funcall (sb-mop:method-function ,m) args ',(mapcar #'make-next nexts)))))
  58                                      (declare (sb-ext:enable-package-locks call-method))
  59                                      ,effective-method)))))
  60           (funcall fun args))))))
  61
  62 (defgeneric foo (a &key b)
  63   (:method ((a integer) &key b) (declare (ignore b)) (1+ a))
  64   (:method ((a string) &key b) (list a b))
  65   (:method ((a symbol) &key b c) (declare (ignore b)) (list a c))
  66   (:method :around ((a integer) &key b) (declare (ignore b)) (1+ (call-next-method)))
  67   (:generic-function-class foo-generic-function))
  68
  69 (with-test (:name (:mop-34 sb-mop:compute-effective-method :interpretable))
  70   (assert (= (foo 1) 3))
  71   (assert (= (foo 1 :b 2) 3))
  72   (assert (equal (foo "a") '("a" nil)))
  73   (assert (equal (foo "a" :b 2) '("a" 2)))
  74   (assert (equal (foo 'a) '(a nil)))
  75   (assert (equal (foo 'a :b 2) '(a nil)))
  76   (assert (equal (foo 'a :c 2) '(a 2)))
  77   (assert (equal (foo 'a :b 2 :c 3) '(a 3))))