1 ;;;; miscellaneous side-effectful tests of the MOP
3 ;;;; This software is part of the SBCL system. See the README file for
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
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.
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.
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
)))
23 (defvar *or-specializer-table
* (make-hash-table :test
'equal
))
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
)))))
33 (defclass gf-with-or
(standard-generic-function) ()
34 (:metaclass sb-mop
:funcallable-standard-class
))
36 (defmethod sb-pcl:specializer-type-specifier
37 ((proto-generic-function gf-with-or
)
39 (specializer or-specializer
))
40 `(or ,@(or-specializer-classes specializer
)))
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
)))
48 (let ((specializer (first (sb-mop:method-specializers m
)))
49 (class (first classes
)))
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
))
56 (return-from sb-mop
:compute-applicable-methods-using-classes
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
)))
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
)))
71 (let ((specializer (first (sb-mop:method-specializers m
)))
72 (argument (first arguments
)))
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
)))
80 (dolist (c (or-specializer-classes specializer
))
81 (when (typep argument c
)
82 (push m applicable-methods
))))))))
83 ;; FIXME: sort the methods
86 (defmethod sb-mop:add-direct-method
((specializer or-specializer
) method
)
87 (pushnew method
(slot-value specializer
'direct-methods
)))
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
))))
93 ;;; FIXME: write SPECIALIZER-DIRECT-GENERIC-FUNCTIONS method
95 (defclass class1
() ())
96 (defclass class2
() ())
97 (defclass class3
() ())
98 (defclass class4
(class1) ())
101 (:generic-function-class gf-with-or
))
103 (let ((specializer (ensure-or-specializer 'class1
'class2
)))
104 (eval `(defmethod foo ((x ,specializer
)) t
)))
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
))))
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
)))