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 sb-pcl:specializer-type-specifier
  44     ((proto-generic-function gf-with-or)
  45      (proto-method t)
  46      (specializer or-specializer))
  47   `(or ,@(or-specializer-classes specializer)))
  48
  49 (defmethod compute-applicable-methods-using-classes
  50     ((generic-function gf-with-or) classes)
  51   ;; FIXME: assume one-argument for now
  52   (let (applicable-methods)
  53     (let ((methods (generic-function-methods generic-function)))
  54       (dolist (m methods)
  55         (let ((specializer (car (method-specializers m)))
  56               (class (car classes)))
  57           (typecase specializer
  58             (class (when (subtypep class specializer)
  59                      (push m applicable-methods)))
  60             (eql-specializer
  61              (when (eql (class-of (eql-specializer-object specializer))
  62                         class)
  63                (return-from compute-applicable-methods-using-classes
  64                  (values nil nil))))
  65             (or-specializer
  66              (dolist (c (or-specializer-classes specializer))
  67                (when (subtypep class c)
  68                  (push m applicable-methods))))))))
  69     ;; FIXME: sort the methods
  70     (values applicable-methods t)))
  71
  72 (defmethod compute-applicable-methods
  73     ((generic-function gf-with-or) arguments)
  74   ;; FIXME: assume one-argument for now
  75   (let (applicable-methods)
  76     (let ((methods (generic-function-methods generic-function)))
  77       (dolist (m methods)
  78         (let ((specializer (car (method-specializers m)))
  79               (argument (car arguments)))
  80           (typecase specializer
  81             (class (when (typep argument specializer)
  82                      (push m applicable-methods)))
  83             (eql-specializer
  84              (when (eql (eql-specializer-object specializer) argument)
  85                (push m applicable-methods)))
  86             (or-specializer
  87              (dolist (c (or-specializer-classes specializer))
  88                (when (typep argument c)
  89                  (push m applicable-methods))))))))
  90     ;; FIXME: sort the methods
  91     applicable-methods))
  92
  93 (defmethod add-direct-method ((specializer or-specializer) method)
  94   (pushnew method (slot-value specializer 'direct-methods)))
  95
  96 (defmethod remove-direct-method ((specializer or-specializer) method)
  97   (setf (slot-value specializer 'direct-methods)
  98         (remove method (slot-value specializer 'direct-methods))))
  99
 100 ;;; FIXME: write SPECIALIZER-DIRECT-GENERIC-FUNCTIONS method
 101
 102 (defclass class1 () ())
 103 (defclass class2 () ())
 104 (defclass class3 () ())
 105 (defclass class4 (class1) ())
 106
 107 (defgeneric foo (x)
 108   (:generic-function-class gf-with-or))
 109
 110 (let ((specializer (ensure-or-specializer 'class1 'class2)))
 111   (eval `(defmethod foo ((x ,specializer)) t)))
 112
 113 (assert (foo (make-instance 'class1)))
 114 (assert (foo (make-instance 'class2)))
 115 (assert-error (foo (make-instance 'class3)))
 116 (assert (foo (make-instance 'class4)))
 117
 118 ;;; check that we are actually cacheing effective methods.  If the
 119 ;;; representation in PCL changes, this test needs to change too.
 120 (assert (typep (cddr (sb-pcl::gf-dfun-state #'foo)) 'sb-pcl::caching))