1.0.23.21: Stack allocated conses for MIPS.
[sbcl.git] / 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))