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 (cl:in-package
:cl-user
)
16 ;;; not really a test for observable behaviour, but: make sure that
17 ;;; all generic functions on startup have lambda lists known to the
18 ;;; system, because some functionality (e.g. &key argument checking)
19 ;;; depends on it. The basic functionality is tested elsewhere, but
20 ;;; this is to investigate the internals for possible inconsistency.
21 (with-test (:name
(:builtin-generic-functions
:known
:lambda-list
))
23 (sb-pcl::map-all-generic-functions
25 (let ((arg-info (sb-pcl::gf-arg-info gf
)))
26 (when (eq (sb-pcl::arg-info-lambda-list arg-info
)
29 (assert (null collect
))))
31 ;;; Regressing test for invalid slot specification error printing
32 (with-test (:name
(defclass :slot
:syntax-error print
))
33 (multiple-value-bind (value err
)
34 (ignore-errors (macroexpand '(defclass foo
() (frob (frob bar
)))))
35 (declare (ignore value
))
36 (assert (typep err
'simple-condition
))
37 (multiple-value-bind (value format-err
)
38 (ignore-errors (apply #'format nil
39 (simple-condition-format-control err
)
40 (simple-condition-format-arguments err
)))
41 (declare (ignore value
))
42 (assert (not format-err
)))))
44 ;;; another not (user-)observable behaviour: make sure that
45 ;;; sb-pcl::map-all-classes calls its function on each class once and
47 (with-test (:name
(sb-pcl::map-all-classes
:no-duplicates
))
49 (sb-pcl::map-all-classes
(lambda (c) (push c result
)))
50 (assert (equal result
(remove-duplicates result
)))))
52 ;;; this one's user-observable
53 (with-test (:name
(type-of (setf class-name
)))
54 (assert (typep #'(setf class-name
) 'generic-function
)))
56 ;;; CLHS 1.4.4.5. We could test for this by defining methods
57 ;;; (i.e. portably) but it's much easier using the MOP and
59 (with-test (:name
:check-standard-superclasses
)
60 (flet ((standardized-class-p (c)
62 (eq (symbol-package (class-name c
))
63 (find-package :cl
)))))
65 (sb-pcl::map-all-classes
66 (lambda (c) (when (standardized-class-p c
)
67 (let* ((cpl (sb-mop:class-precedence-list c
))
68 (std (position (find-class 'standard-object
) cpl
))
69 (str (position (find-class 'structure-object
) cpl
))
71 #'standardized-class-p
(butlast cpl
)
74 (push `(:and
,c
) result
))
75 (when (and str
(< str last
))
76 (push `(:str
,c
) result
))
77 (when (and std
(< std last
))
78 (push `(:std
,c
) result
))))))
79 (assert (null result
)))))
81 ;; No compiler-notes for non-constant slot-names in default policy.
82 (with-test (:name
(slot-value :no sb-ext
:compiler-note
))
83 (checked-compile '(lambda (x y z
)
84 (setf (slot-value x z
) (slot-value y z
)))
87 (with-test (:name
:slot-table-of-symbol-works
)
89 ;; the error that I want is about a missing slot,
90 ;; not a missing method, so don't let the compiler turn
91 ;; this into (funcall #'(SLOT-ACCESSOR :GLOBAL A READER)...)
92 (handler-case (eval '(slot-value 'a
'a
))
94 (and (search "slot ~S is missing"
95 (simple-condition-format-control c
))
98 (with-test (:name
:funcallable-instance-sxhash
)
100 (/= (sxhash (make-instance 'sb-mop
:funcallable-standard-object
))
101 (sxhash (make-instance 'sb-mop
:funcallable-standard-object
))
104 (with-test (:name
(typep :literal-class
))
105 (checked-compile-and-assert ()
107 (typep x
#.
(find-class 'symbol
)))