1 ;;;; CLOS tests with no side effects
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 ;;; not really a test for observable behaviour, but: make sure that
15 ;;; all generic functions on startup have lambda lists known to the
16 ;;; system, because some functionality (e.g. &key argument checking)
17 ;;; depends on it. The basic functionality is tested elsewhere, but
18 ;;; this is to investigate the internals for possible inconsistency.
19 (with-test (:name
(:builtin-generic-functions
:known
:lambda-list
))
21 (sb-pcl::map-all-generic-functions
23 (let ((arg-info (sb-pcl::gf-arg-info gf
)))
24 (when (eq (sb-pcl::arg-info-lambda-list arg-info
)
27 (assert (null collect
))))
29 ;;; Regressing test for invalid slot specification error printing
30 (with-test (:name
(defclass :slot
:syntax-error print
))
31 (multiple-value-bind (value err
)
32 (ignore-errors (macroexpand '(defclass foo
() (frob (frob bar
)))))
33 (declare (ignore value
))
34 (assert (typep err
'simple-condition
))
35 (multiple-value-bind (value format-err
)
36 (ignore-errors (apply #'format nil
37 (simple-condition-format-control err
)
38 (simple-condition-format-arguments err
)))
39 (declare (ignore value
))
40 (assert (not format-err
)))))
42 (with-test (:name
(defclass :initform type-error
))
44 (assert (nth-value 1 (checked-compile
45 `(lambda () ,form
) :allow-warnings t
))))
46 '(;; Special-cased initforms
47 (defclass foo
() ((%bar
:type integer
:initform t
)))
48 (defclass foo
() ((%bar
:type integer
:initform nil
)))
49 (defclass foo
() ((%bar
:type boolean
:initform
0)))
51 (defclass foo
() ((%bar
:type integer
:initform
(lisp-implementation-version))))
52 (defclass foo
() ((%bar
:type boolean
:initform
(random 2)))))))
54 ;;; another not (user-)observable behaviour: make sure that
55 ;;; sb-pcl::map-all-classes calls its function on each class once and
57 (with-test (:name
(sb-pcl::map-all-classes
:no-duplicates
))
59 (sb-pcl::map-all-classes
(lambda (c) (push c result
)))
60 (assert (equal result
(remove-duplicates result
)))))
62 ;;; this one's user-observable
63 (with-test (:name
(type-of (setf class-name
)))
64 (assert (typep #'(setf class-name
) 'generic-function
)))
66 ;;; CLHS 1.4.4.5. We could test for this by defining methods
67 ;;; (i.e. portably) but it's much easier using the MOP and
69 (with-test (:name
:check-standard-superclasses
)
70 (flet ((standardized-class-p (c)
72 (eq (symbol-package (class-name c
))
73 (find-package :cl
)))))
75 (sb-pcl::map-all-classes
76 (lambda (c) (when (standardized-class-p c
)
77 (let* ((cpl (sb-mop:class-precedence-list c
))
78 (std (position (find-class 'standard-object
) cpl
))
79 (str (position (find-class 'structure-object
) cpl
))
81 #'standardized-class-p
(butlast cpl
)
84 (push `(:and
,c
) result
))
85 (when (and str
(< str last
))
86 (push `(:str
,c
) result
))
87 (when (and std
(< std last
))
88 (push `(:std
,c
) result
))))))
89 (assert (null result
)))))
91 ;; No compiler-notes for non-constant slot-names in default policy.
92 (with-test (:name
(slot-value :no sb-ext
:compiler-note
))
93 (checked-compile '(lambda (x y z
)
94 (setf (slot-value x z
) (slot-value y z
)))
97 (defun assert-no-such-slot (obj slot-name
)
98 (dolist (method '(slot-value slot-boundp
))
100 ;; the error that I want is about a missing slot,
101 ;; not a missing method, so don't let the compiler turn
102 ;; this into (funcall #'(SLOT-ACCESSOR :GLOBAL A READER)...)
103 (handler-case (eval `(,method
',obj
',slot-name
))
104 (simple-condition (c)
105 (and (search "slot ~S is missing"
106 (simple-condition-format-control c
))
108 ;; and of course SLOT-EXISTS-P should just return NIL
109 (assert (not (slot-exists-p obj slot-name
))))
111 (with-test (:name
:slot-table-of-builtin-classoids
)
112 (assert-no-such-slot 'some-symbol
'some-slot
)
113 (assert-no-such-slot #P
"foo" 'some-slot
)
114 (let ((lpn #p
"sys:contrib;"))
115 (assert (typep lpn
'logical-pathname
))
116 (assert-no-such-slot lpn
'some-slot
)))
118 (with-test (:name
:funcallable-instance-sxhash
)
120 (/= (sxhash (make-instance 'sb-mop
:funcallable-standard-object
))
121 (sxhash (make-instance 'sb-mop
:funcallable-standard-object
))
124 (with-test (:name
(typep :literal-class
))
125 (checked-compile-and-assert ()
127 (typep x
#.
(find-class 'symbol
)))
130 (with-test (:name
:slot-value-on-not-slot-object
)
131 (checked-compile-and-assert ()
134 ((nil) (condition 'sb-pcl
::missing-slot
)))
135 (checked-compile-and-assert ()
138 ((1) (condition 'sb-pcl
::missing-slot
)))
139 (checked-compile-and-assert ()
141 (setf (slot-value x
'j
) 30))
142 ((1.0
) (condition 'sb-pcl
::missing-slot
)))
143 (checked-compile-and-assert ()
145 (slot-makunbound x
'l
))
146 ((#\a) (condition 'sb-pcl
::missing-slot
))))
149 (with-test (:name
:illegal-class-name
)
150 (checked-compile-and-assert
154 (('(t)) (condition 'sb-kernel
::illegal-class-name-error
))))