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 (load "assertoid.lisp")
  20
  21 (defpackage "OR-SPECIALIZER-TEST"
  22   (:use "CL" "SB-MOP" "ASSERTOID"))
  23
  24 (in-package "OR-SPECIALIZER-TEST")
  25
  26 (defclass or-specializer (specializer)
  27   ((classes :initform nil :reader or-specializer-classes :initarg :classes)
  28    (direct-methods :initform nil :reader specializer-direct-methods)))
  29
  30 (defvar *or-specializer-table* (make-hash-table :test 'equal))
  31
  32 (defun ensure-or-specializer (&rest classes)
  33   ;; FIXME: duplicate hash values
  34   (let* ((cs (mapcar (lambda (x) (if (symbolp x) (find-class x) x)) classes))
  35          (sorted-classes (sort cs #'< :key #'sxhash)))
  36     (or (gethash sorted-classes *or-specializer-table*)
  37         (setf (gethash sorted-classes *or-specializer-table*)
  38               (make-instance 'or-specializer :classes sorted-classes)))))
  39
  40 (defclass gf-with-or (standard-generic-function) ()
  41   (:metaclass funcallable-standard-class))
  42
  43 (defmethod compute-applicable-methods-using-classes
  44     ((generic-function gf-with-or) classes)
  45   ;; FIXME: assume one-argument for now
  46   (let (applicable-methods)
  47     (let ((methods (generic-function-methods generic-function)))
  48       (dolist (m methods)
  49         (let ((specializer (car (method-specializers m)))
  50               (class (car classes)))
  51           (typecase specializer
  52             (class (when (subtypep class specializer)
  53                      (push m applicable-methods)))
  54             (eql-specializer
  55              (when (eql (class-of (eql-specializer-object specializer))
  56                         class)
  57                (return-from compute-applicable-methods-using-classes
  58                  (values nil nil))))
  59             (or-specializer
  60              (dolist (c (or-specializer-classes specializer))
  61                (when (subtypep class c)
  62                  (push m applicable-methods))))))))
  63     ;; FIXME: sort the methods
  64     (values applicable-methods t)))
  65
  66 (defmethod compute-applicable-methods
  67     ((generic-function gf-with-or) arguments)
  68   ;; FIXME: assume one-argument for now
  69   (let (applicable-methods)
  70     (let ((methods (generic-function-methods generic-function)))
  71       (dolist (m methods)
  72         (let ((specializer (car (method-specializers m)))
  73               (argument (car arguments)))
  74           (typecase specializer
  75             (class (when (typep argument specializer)
  76                      (push m applicable-methods)))
  77             (eql-specializer
  78              (when (eql (eql-specializer-object specializer) argument)
  79                (push m applicable-methods)))
  80             (or-specializer
  81              (dolist (c (or-specializer-classes specializer))
  82                (when (typep argument c)
  83                  (push m applicable-methods))))))))
  84     ;; FIXME: sort the methods
  85     applicable-methods))
  86
  87 (defmethod add-direct-method ((specializer or-specializer) method)
  88   (pushnew method (slot-value specializer 'direct-methods)))
  89
  90 (defmethod remove-direct-method ((specializer or-specializer) method)
  91   (setf (slot-value specializer 'direct-methods)
  92         (remove method (slot-value specializer 'direct-methods))))
  93
  94 ;;; FIXME: write SPECIALIZER-DIRECT-GENERIC-FUNCTIONS method
  95
  96 (defclass class1 () ())
  97 (defclass class2 () ())
  98 (defclass class3 () ())
  99 (defclass class4 (class1) ())
 100
 101 (defgeneric foo (x)
 102   (:generic-function-class gf-with-or))
 103
 104 (let ((specializer (ensure-or-specializer 'class1 'class2)))
 105   (eval `(defmethod foo ((x ,specializer)) t)))
 106
 107 (assert (foo (make-instance 'class1)))
 108 (assert (foo (make-instance 'class2)))
 109 (assert (raises-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 (assert (typep (cddr (sb-pcl::gf-dfun-state #'foo)) 'sb-pcl::caching))