1 ;;;; miscellaneous 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 ;;; be sure that the :FUNCTION initarg to initialize methods overrides
15 ;;; any system-provided function.
17 (defclass typechecking-reader-method
(standard-reader-method)
20 (defmethod initialize-instance
21 ((method typechecking-reader-method
) &rest initargs
&key slot-definition
)
22 (let ((name (sb-mop:slot-definition-name slot-definition
))
23 (type (sb-mop:slot-definition-type slot-definition
)))
24 (apply #'call-next-method method
25 :function
#'(lambda (args next-methods
)
26 (declare (ignore next-methods
))
27 (apply #'(lambda (instance)
28 (let ((value (slot-value instance name
)))
29 (unless (typep value type
)
30 (error "Slot ~S of ~S is not of type ~S: ~S"
31 name instance type value
))
35 (defclass typechecking-reader-class
(standard-class)
38 (defmethod sb-mop:validate-superclass
((c1 typechecking-reader-class
) (c2 standard-class
))
41 (defmethod reader-method-class
42 ((class typechecking-reader-class
) direct-slot
&rest args
)
43 (declare (ignore args
))
44 (find-class 'typechecking-reader-method
))
46 (defclass testclass25
()
47 ((pair :type
(cons symbol
(cons symbol null
)) :initarg
:pair
:accessor testclass25-pair
))
48 (:metaclass typechecking-reader-class
))
50 (with-test (:name
(:mop-24
))
51 (let ((p (list 'abc
'def
))
52 (x (make-instance 'testclass25
)))
53 (assert-no-signal (make-instance 'testclass25
:pair
'(seventeen 17)))
54 (assert-no-signal (setf (testclass25-pair x
) p
))
55 (assert-no-signal (setf (second p
) 456))
56 (assert-no-signal (testclass25-pair x
))
57 (assert-no-signal (slot-value x
'pair
))))