tests/mop-28.impure.lisp

   1 ;;;; miscellaneous side-effectful tests of the MOP
   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 ;;; a test of a non-standard specializer class and non-standard
  15 ;;; generic function class, which nevertheless admit the cacheing
  16 ;;; strategy implicit in the second return value of
  17 ;;; compute-applicable-methods-using-classes.
  18
  19 (defclass or-specializer (sb-mop:specializer)
  20   ((classes :initform nil :reader or-specializer-classes :initarg :classes)
  21    (direct-methods :initform nil :reader specializer-direct-methods)))
  22
  23 (defvar *or-specializer-table* (make-hash-table :test 'equal))
  24
  25 (defun ensure-or-specializer (&rest classes)
  26   ;; FIXME: duplicate hash values
  27   (let* ((cs (mapcar (lambda (x) (if (symbolp x) (find-class x) x)) classes))
  28          (sorted-classes (sort cs #'< :key #'sxhash)))
  29     (or (gethash sorted-classes *or-specializer-table*)
  30         (setf (gethash sorted-classes *or-specializer-table*)
  31               (make-instance 'or-specializer :classes sorted-classes)))))
  32
  33 (defclass gf-with-or (standard-generic-function) ()
  34   (:metaclass sb-mop:funcallable-standard-class))
  35
  36 (defmethod sb-pcl:specializer-type-specifier
  37     ((proto-generic-function gf-with-or)
  38      (proto-method t)
  39      (specializer or-specializer))
  40   `(or ,@(or-specializer-classes specializer)))
  41
  42 (defmethod sb-mop:compute-applicable-methods-using-classes
  43     ((generic-function gf-with-or) classes)
  44   ;; FIXME: assume one-argument for now
  45   (let (applicable-methods)
  46     (let ((methods (sb-mop:generic-function-methods generic-function)))
  47       (dolist (m methods)
  48         (let ((specializer (first (sb-mop:method-specializers m)))
  49               (class (first classes)))
  50           (typecase specializer
  51             (class (when (subtypep class specializer)
  52                      (push m applicable-methods)))
  53             (sb-mop:eql-specializer
  54              (when (eql (class-of (sb-mop:eql-specializer-object specializer))
  55                         class)
  56                (return-from sb-mop:compute-applicable-methods-using-classes
  57                  (values nil nil))))
  58             (or-specializer
  59              (dolist (c (or-specializer-classes specializer))
  60                (when (subtypep class c)
  61                  (push m applicable-methods))))))))
  62     ;; FIXME: sort the methods
  63     (values applicable-methods t)))
  64
  65 (defmethod sb-mop:compute-applicable-methods
  66     ((generic-function gf-with-or) arguments)
  67   ;; FIXME: assume one-argument for now
  68   (let (applicable-methods)
  69     (let ((methods (sb-mop:generic-function-methods generic-function)))
  70       (dolist (m methods)
  71         (let ((specializer (first (sb-mop:method-specializers m)))
  72               (argument (first arguments)))
  73           (typecase specializer
  74             (class (when (typep argument specializer)
  75                      (push m applicable-methods)))
  76             (sb-mop:eql-specializer
  77              (when (eql (sb-mop:eql-specializer-object specializer) argument)
  78                (push m applicable-methods)))
  79             (or-specializer
  80              (dolist (c (or-specializer-classes specializer))
  81                (when (typep argument c)
  82                  (push m applicable-methods))))))))
  83     ;; FIXME: sort the methods
  84     applicable-methods))
  85
  86 (defmethod sb-mop:add-direct-method ((specializer or-specializer) method)
  87   (pushnew method (slot-value specializer 'direct-methods)))
  88
  89 (defmethod sb-mop:remove-direct-method ((specializer or-specializer) method)
  90   (setf (slot-value specializer 'direct-methods)
  91         (remove method (slot-value specializer 'direct-methods))))
  92
  93 ;;; FIXME: write SPECIALIZER-DIRECT-GENERIC-FUNCTIONS method
  94
  95 (defclass class1 () ())
  96 (defclass class2 () ())
  97 (defclass class3 () ())
  98 (defclass class4 (class1) ())
  99
 100 (defgeneric foo (x)
 101   (:generic-function-class gf-with-or))
 102
 103 (let ((specializer (ensure-or-specializer 'class1 'class2)))
 104   (eval `(defmethod foo ((x ,specializer)) t)))
 105
 106 (with-test (:name (:mop-28 1))
 107   (assert (foo (make-instance 'class1)))
 108   (assert (foo (make-instance 'class2)))
 109   (assert-error (foo (make-instance 'class3)))
 110   (assert (foo (make-instance 'class4))))
 111
 112 ;;; check that we are actually cacheing effective methods.  If the
 113 ;;; representation in PCL changes, this test needs to change too.
 114 (with-test (:name (:mop-28 2))
 115   (assert (typep (cddr (sb-pcl::gf-dfun-state #'foo)) 'sb-pcl::caching)))