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 ;;; this file contains tests of (SETF CLASS-NAME) and (SETF
15 ;;; GENERIC-FUNCTION-NAME)
17 (defclass metaclass
/ri
(standard-class)
19 (defmethod sb-mop:validate-superclass
((c metaclass
/ri
) (s standard-class
))
23 (:metaclass metaclass
/ri
))
24 (defvar *class
/ri-args
* nil
)
25 (defmethod reinitialize-instance :after
((o metaclass
/ri
) &rest initargs
)
26 (setf *class
/ri-args
* initargs
))
28 (with-test (:name
((setf class-name
) reinitialize-instance
))
29 (let ((class (find-class 'class
/ri
)))
30 (setf (class-name class
) 'name
)
31 (assert (equal *class
/ri-args
* '(:name name
)))
32 (setf (class-name class
) 'class
/ri
)
33 (assert (equal *class
/ri-args
* '(:name class
/ri
)))))
35 (defclass dependent
()
36 ((slot :initform nil
:accessor dependent-slot
)))
37 (defclass class
/dependent
()
39 (defvar *dependent
* (make-instance 'dependent
))
40 (defmethod sb-mop:update-dependent
((object standard-class
)
43 (setf (dependent-slot dependent
) args
))
45 (with-test (:name
((setf class-name
) sb-mop
:update-dependent
))
46 (let ((class (find-class 'class
/dependent
)))
47 (sb-mop:add-dependent class
*dependent
*)
48 (setf (class-name class
) 'name
)
49 (assert (equal (dependent-slot *dependent
*) '(:name name
)))
50 (sb-mop:remove-dependent class
*dependent
*)
51 (setf (class-name class
) 'name
)
52 (assert (equal (dependent-slot *dependent
*) '(:name name
)))))
54 (defclass gfc
/ri
(standard-generic-function)
56 (:metaclass sb-mop
:funcallable-standard-class
))
58 (:generic-function-class gfc
/ri
))
59 (defvar *gf
/ri-args
* nil
)
60 (defmethod reinitialize-instance :after
((o gfc
/ri
) &rest initargs
)
61 (setf *gf
/ri-args
* initargs
))
63 (with-test (:name
((setf sb-mop
:generic-function-name
) reinitialize-instance
))
65 (setf (sb-mop:generic-function-name gf
) 'name
)
66 (assert (equal *gf
/ri-args
* '(:name name
)))
67 (setf (sb-mop:generic-function-name gf
) 'gf
/ri
)
68 (assert (equal *gf
/ri-args
* '(:name gf
/ri
)))))
70 (defgeneric gf
/dependent
())
71 (defmethod sb-mop:update-dependent
((object standard-generic-function
)
74 (setf (dependent-slot dependent
) args
))
76 (with-test (:name
((setf sb-mop
:generic-function-name
) sb-mop
:update-dependent
))
77 (let ((gf (find-class 'class
/dependent
)))
78 (sb-mop:add-dependent gf
*dependent
*)
79 (setf (sb-mop:generic-function-name gf
) 'gf
/name
)
80 (assert (equal (dependent-slot *dependent
*) '(:name gf
/name
)))
81 (sb-mop:remove-dependent gf
*dependent
*)
82 (setf (sb-mop:generic-function-name gf
) 'gf
/dependent
)
83 (assert (equal (dependent-slot *dependent
*) '(:name gf
/name
)))))