1 ;;;; miscellaneous non-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 ;;;; Note that the MOP is not in an entirely supported state.
15 ;;;; However, this seems a good a way as any of ensuring that we have
18 (assert (subtypep 'sb-mop
:funcallable-standard-object
'standard-object
))
20 (assert (find (find-class 'sb-mop
:funcallable-standard-object
)
21 (sb-mop:class-direct-subclasses
(find-class 'standard-object
))))
23 (assert (find (find-class 'standard-object
)
24 (sb-mop:class-direct-superclasses
25 (find-class 'sb-mop
:funcallable-standard-object
))))
27 (dolist (name '(sb-mop:generic-function
28 sb-mop
:method sb-mop
:method-combination
29 sb-mop
:slot-definition sb-mop
:specializer
))
30 (assert (find (find-class 'sb-mop
:metaobject
)
31 (sb-mop:class-direct-superclasses
(find-class name
))))
32 (assert (subtypep name
'sb-mop
:metaobject
)))
34 ;;; No portable class Cp may inherit, by virtue of being a direct or
35 ;;; indirect subclass of a specified class, any slot for which the
36 ;;; name is a symbol accessible in the common-lisp-user package or
37 ;;; exported by any package defined in the ANSI Common Lisp standard.
38 (let ((specified-class-names
39 '(sb-mop:built-in-class
41 sb-mop
:direct-slot-definition
42 sb-mop
:effective-slot-definition
43 sb-mop
:eql-specializer
44 sb-mop
:forward-referenced-class
45 sb-mop
:funcallable-standard-class
46 sb-mop
:funcallable-standard-object
47 sb-mop
:generic-function
50 sb-mop
:method-combination
51 sb-mop
:slot-definition
53 sb-mop
:standard-accessor-method
55 sb-mop
:standard-direct-slot-definition
56 sb-mop
:standard-effective-slot-definition
57 sb-mop
:standard-generic-function
58 sb-mop
:standard-method
59 sb-mop
:standard-object
60 sb-mop
:standard-reader-method
61 sb-mop
:standard-slot-definition
62 sb-mop
:standard-writer-method
)))
63 (labels ((slot-name-ok (name)
64 (dolist (package (mapcar #'find-package
65 '("CL" "CL-USER" "KEYWORD" "SB-MOP"))
67 (when (multiple-value-bind (symbol status
)
68 (find-symbol (symbol-name name
) package
)
70 (or (eq package
(find-package "CL-USER"))
71 (eq status
:external
))))
73 (test-class-slots (class)
74 (loop for slot in
(sb-mop:class-slots class
)
75 for slot-name
= (sb-mop:slot-definition-name slot
)
76 unless
(slot-name-ok slot-name
)
77 collect
(cons class slot-name
))))
78 (loop for class-name in specified-class-names
79 for class
= (find-class class-name
)
80 for results
= (test-class-slots class
)
81 when results do
(cerror "continue" "~A" results
))))
83 (with-test (:name
:bug-936513
)
84 ;; This used to fail as ENSURE-GENERIC-FUNCTION wanted a list specifying
85 ;; the method combination, and didn't accept the actual object
86 (let ((mc (sb-mop:find-method-combination
#'make-instance
'standard nil
)))
87 (ensure-generic-function 'make-instance
:method-combination mc
))
88 ;; Let's make sure the list works too...
89 (ensure-generic-function 'make-instance
:method-combination
'(standard)))
91 (with-test (:name
:bug-309072
)
92 ;; original reported test cases
93 (assert-error (make-instance 'sb-mop
:slot-definition
)
94 sb-pcl
::slotd-initialization-error
)
95 (assert-error (make-instance 'sb-mop
:slot-definition
:name
'pi
)
96 sb-pcl
::slotd-initialization-error
)
97 (assert-error (make-instance 'sb-mop
:slot-definition
:name
3)
98 sb-pcl
::slotd-initialization-type-error
)
99 ;; extra cases from the MOP dictionary
100 (assert-error (make-instance 'sb-mop
:slot-definition
:name
'x
102 sb-pcl
::slotd-initialization-error
)
103 (assert-error (make-instance 'sb-mop
:slot-definition
:name
'x
104 :initfunction
(lambda () nil
))
105 sb-pcl
::slotd-initialization-error
)
106 (assert-error (make-instance 'sb-mop
:slot-definition
:name
'x
107 :initfunction
(lambda () nil
))
108 sb-pcl
::slotd-initialization-error
)
109 (assert-error (make-instance 'sb-mop
:slot-definition
:name
'x
111 sb-pcl
::slotd-initialization-error
)
112 (assert-error (make-instance 'sb-mop
:slot-definition
:name
'x
114 sb-pcl
::slotd-initialization-error
)
115 (assert-error (make-instance 'sb-mop
:slot-definition
:name
'x
116 :initargs
'(foo . bar
))
117 sb-pcl
::slotd-initialization-error
)
118 (assert-error (make-instance 'sb-mop
:slot-definition
:name
'x
119 :initargs
'(foo bar
3))
120 sb-pcl
::slotd-initialization-error
)
121 (assert-error (make-instance 'sb-mop
:slot-definition
:name
'x
122 :documentation
'(()))
123 sb-pcl
::slotd-initialization-error
)
124 ;; distinction between DIRECT- and EFFECTIVE- slot definitions
125 (assert-error (make-instance 'sb-mop
:effective-slot-definition
126 :name
'x
:readers
'(foo))
127 sb-pcl
::initarg-error
)
128 (assert-error (make-instance 'sb-mop
:effective-slot-definition
129 :name
'x
:writers
'(foo))
130 sb-pcl
::initarg-error
)
131 (make-instance 'sb-mop
:direct-slot-definition
132 :name
'x
:readers
'(foo))
133 (make-instance 'sb-mop
:direct-slot-definition
134 :name
'x
:writers
'(foo))
135 (assert-error (make-instance 'sb-mop
:direct-slot-definition
136 :name
'x
:readers
"")
137 sb-pcl
::slotd-initialization-error
)
138 (assert-error (make-instance 'sb-mop
:direct-slot-definition
139 :name
'x
:readers
'(3))
140 sb-pcl
::slotd-initialization-error
)
141 (assert-error (make-instance 'sb-mop
:direct-slot-definition
142 :name
'x
:readers
'(foo . bar
))
143 sb-pcl
::slotd-initialization-error
)
144 (assert-error (make-instance 'sb-mop
:direct-slot-definition
145 :name
'x
:writers
"")
146 sb-pcl
::slotd-initialization-error
)
147 (assert-error (make-instance 'sb-mop
:direct-slot-definition
148 :name
'x
:writers
'(3))
149 sb-pcl
::slotd-initialization-error
)
150 (assert-error (make-instance 'sb-mop
:direct-slot-definition
151 :name
'x
:writers
'(foo . bar
))
152 sb-pcl
::slotd-initialization-error
))
154 (with-test (:name
(:bug-1332983
:validate-superclass stream t
))
156 (sb-mop:validate-superclass
(find-class 'stream
) (find-class 't
))))
158 (with-test (:name
(:bug-1049423
:duplicate-effective-slots
))
159 (flet ((check (descendant-name ancestor-name slot-name
)
160 (let ((kid (find-class descendant-name
))
161 (par (find-class ancestor-name
)))
162 (assert (find par
(sb-mop:class-precedence-list kid
)))
163 ;; each specifies SLOT-NAME as a slot name
164 (find slot-name
(sb-mop:class-direct-slots kid
)
165 :key
'sb-mop
:slot-definition-name
)
166 (find slot-name
(sb-mop:class-direct-slots par
)
167 :key
'sb-mop
:slot-definition-name
)
168 ;; there is only one effective slot of that name
169 (assert (= 1 (count slot-name
(sb-mop:class-slots kid
)
170 :key
'sb-mop
:slot-definition-name
))))))
171 ;; metaclass = structure-class
172 ;; FUN-TYPE inherits CTYPE
173 (check 'sb-kernel
:fun-type
'sb-kernel
:ctype
'sb-kernel
::%bits
)
174 ;; metaclass = condition-class
175 ;; REDEFINITION-WITH-DEFMETHOD inherits REDEFINITION-WARNING
176 (check 'sb-kernel
:redefinition-with-defmethod
177 'sb-kernel
:redefinition-warning
178 'sb-kernel
::new-location
)))
180 ;; Do a quick test of FIND-SLOT-CELL for all slots of all classes with slots
181 (with-test (:name
:sanity-check-find-slot-cell
)
183 (let ((class (find-class s nil
)))
184 (when (and class
(ignore-errors (sb-mop:class-slots class
)))
185 (let ((layout (sb-kernel:find-layout s
)))
186 (dolist (slot-name (mapcar #'sb-mop
:slot-definition-name
187 (sb-mop:class-slots class
)))
188 (assert (sb-pcl::find-slot-cell layout slot-name
))))))))
190 (with-test (:name
(typep sb-mop
:class-precedence-list
))
191 (let* ((objs (list (make-hash-table) (make-pathname) (make-condition 'warning
)
192 (find-class 't
) #'make-instance
)))
194 (let ((cpl (sb-mop:class-precedence-list
(class-of obj
))))
196 (assert (typep obj sc
)))))))