1 ;;;; Constructing and instantiating subclasses of system classes
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 (defmacro assert-subtype
(class type
)
16 (assert-tri-eq t t
(subtypep ',class
',type
))
17 (assert-instance-type ,class
,type
)))
19 (defmacro assert-instance-type
(class type
)
20 `(flet ((compiled (x) (typep x
',type
))
21 (evaled (x y
) (typep x
(opaque-identity y
))))
22 (assert (typep (make-instance ',class
) ',type
))
23 (assert (compiled (make-instance ',class
)))
24 (assert (evaled (make-instance ',class
) ',type
))))
26 (defmacro assert-callable
(class)
27 `(let ((i (make-instance ',class
)))
28 (sb-mop:set-funcallable-instance-function i
(lambda (x) (1+ x
)))
29 (assert (= (funcall i
51) 52))))
31 (macrolet ((test (stype)
32 (let ((sname (intern (concatenate 'string
"%" (symbol-name stype
))))
33 (fsname (intern (concatenate 'string
"%F" (symbol-name stype
)))))
35 (defclass ,sname
(,stype standard-object
)
37 (with-test (:name
(,stype standard-object
))
38 (assert-subtype ,sname
,stype
)
39 (assert-instance-type ,sname
(not function
))
40 (assert-instance-type ,sname
(not sequence
)))
42 (defclass ,fsname
(,stype sb-mop
:funcallable-standard-object
)
44 (:metaclass sb-mop
:funcallable-standard-class
))
45 (with-test (:name
(,stype function type
))
46 (assert-subtype ,fsname
,stype
)
47 (assert-subtype ,fsname function
)
48 (assert-instance-type ,fsname
(not sequence
)))
49 (with-test (:name
(,stype function funcall
))
50 (assert-callable ,fsname
))))))
55 (defclass %sequence
(sequence standard-object
)
57 (with-test (:name
(sequence standard-object
))
58 (assert-subtype %sequence sequence
)
59 (assert-instance-type %sequence
(not function
))
60 (assert-instance-type %sequence
(not stream
)))
62 (defclass %fsequence
(sequence sb-mop
:funcallable-standard-object
)
64 (:metaclass sb-mop
:funcallable-standard-class
))
65 (with-test (:name
(sequence function type
))
66 (assert-subtype %fsequence sequence
)
67 (assert-subtype %fsequence function
)
68 (assert-instance-type %fsequence
(not stream
)))
69 (with-test (:name
(sequence function funcall
))
70 (assert-callable %fsequence
))
72 (macrolet ((test (stype)
73 (let ((sname (intern (concatenate 'string
"%SEQ" (symbol-name stype
))))
74 (fsname (intern (concatenate 'string
"%FSEQ" (symbol-name stype
)))))
76 (defclass ,sname
(,stype sequence standard-object
)
78 (with-test (:name
(,stype sequence standard-object
))
79 (assert-subtype ,sname
,stype
)
80 (assert-instance-type ,sname
(not function
))
81 (assert-subtype ,sname sequence
))
83 (defclass ,fsname
(,stype sequence sb-mop
:funcallable-standard-object
)
85 (:metaclass sb-mop
:funcallable-standard-class
))
86 (with-test (:name
(,stype sequence function
))
87 (assert-subtype ,fsname
,stype
)
88 (assert-subtype ,fsname function
)
89 (assert-subtype ,fsname sequence
))
90 (with-test (:name
(,stype sequence function funcall
))
91 (assert-callable ,fsname
))))))