1 ;;;; Standard-instance-access tests and update-protocol abuse
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.
16 (quux :initarg
:quux
)))
21 (defun find-slot (name class
)
22 (let ((class (sb-pcl:ensure-class-finalized
(find-class class
))))
23 (find name
(sb-mop:class-slots class
) :key
#'sb-mop
:slot-definition-name
)))
25 (sb-mop:add-dependent
(find-class 'foo
) (find-class 'foomagic
))
27 (defglobal **bar-loc
** (sb-mop:slot-definition-location
(find-slot 'bar
'foo
)))
28 (defglobal **quux-loc
** (sb-mop:slot-definition-location
(find-slot 'quux
'foo
)))
30 (defmethod sb-mop:update-dependent
((meta (eql (find-class 'foo
)))
31 (dep (eql (find-class 'foomagic
)))
33 (setf **bar-loc
** (sb-mop:slot-definition-location
(find-slot 'bar
'foo
))
34 **quux-loc
** (sb-mop:slot-definition-location
(find-slot 'quux
'foo
))))
36 (defun foo-bar/quux
(foo)
37 (declare (type foo foo
))
38 (values (sb-mop:standard-instance-access foo
**bar-loc
**)
39 (sb-mop:standard-instance-access foo
**quux-loc
**)))
41 (defun swap-bar/quux
(foo)
42 (declare (type foo foo
))
43 (rotatef (sb-mop:standard-instance-access foo
**bar-loc
**)
44 (sb-mop:standard-instance-access foo
**quux-loc
**)))
46 (with-test (:name
(:mop-30 sb-mop
:standard-instance-access
))
47 (let ((bar (cons t t
))
48 (quux (cons nil nil
)))
49 (multiple-value-bind (bar? quux?
)
50 (foo-bar/quux
(make-instance 'foo
:bar bar
:quux quux
))
51 (assert (eq bar bar?
))
52 (assert (eq quux quux?
)))))
54 (with-test (:name
(:mop-30
(setf sb-mop
::standard-instance-access
)))
55 (let* ((bar (cons t t
))
58 (make-instance 'foo
:bar bar
:quux quux
)))
59 (multiple-value-bind (bar? quux?
) (foo-bar/quux foo
)
60 (assert (eq bar bar?
))
61 (assert (eq quux quux?
)))
63 (multiple-value-bind (bar? quux?
) (foo-bar/quux foo
)
64 (assert (eq quux bar?
))
65 (assert (eq bar quux?
)))))
67 ;;; Sneaky redefinition reorders slots!
69 ((quux :initarg
:quux
)
72 (with-test (:name
(:mop-30 sb-mop
:standard-instance-access
:updated
))
73 (let ((bar (cons t t
))
74 (quux (cons nil nil
)))
75 (multiple-value-bind (bar? quux?
)
76 (foo-bar/quux
(make-instance 'foo
:bar bar
:quux quux
))
77 (assert (eq bar bar?
))
78 (assert (eq quux quux?
)))))
80 (with-test (:name
(:mop-30 sb-mop
:standard-instance-access slot-unbound
))
81 (let ((bar (cons t t
)))
82 (multiple-value-bind (bar? quux?
)
83 (foo-bar/quux
(make-instance 'foo
:bar bar
))
84 (assert (eq bar bar?
))
85 (assert (eq sb-pcl
:+slot-unbound
+ quux?
)))))