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)
18 (:use "CL" "SB-MOP" "TEST-UTIL"))
22 (defclass metaclass/ri (standard-class)
24 (defmethod validate-superclass ((c metaclass/ri) (s standard-class))
28 (:metaclass metaclass/ri))
29 (defvar *class/ri-args* nil)
30 (defmethod reinitialize-instance :after ((o metaclass/ri) &rest initargs)
31 (setf *class/ri-args* initargs))
32 (with-test (:name ((setf class-name) reinitialize-instance))
33 (let ((class (find-class 'class/ri)))
34 (setf (class-name class) 'name)
35 (assert (equal *class/ri-args* '(:name name)))
36 (setf (class-name class) 'class/ri)
37 (assert (equal *class/ri-args* '(:name class/ri)))))
39 (defclass dependent ()
40 ((slot :initform nil :accessor dependent-slot)))
41 (defclass class/dependent ()
43 (defvar *dependent* (make-instance 'dependent))
44 (defmethod update-dependent ((object standard-class) (dependent dependent)
46 (setf (dependent-slot dependent) args))
47 (with-test (:name ((setf class-name) update-dependent))
48 (let ((class (find-class 'class/dependent)))
49 (add-dependent class *dependent*)
50 (setf (class-name class) 'name)
51 (assert (equal (dependent-slot *dependent*) '(:name name)))
52 (remove-dependent class *dependent*)
53 (setf (class-name class) 'name)
54 (assert (equal (dependent-slot *dependent*) '(:name name)))))
56 (defclass gfc/ri (standard-generic-function)
58 (:metaclass funcallable-standard-class))
60 (:generic-function-class gfc/ri))
61 (defvar *gf/ri-args* nil)
62 (defmethod reinitialize-instance :after ((o gfc/ri) &rest initargs)
63 (setf *gf/ri-args* initargs))
64 (with-test (:name ((setf generic-function-name) reinitialize-instance))
66 (setf (generic-function-name gf) 'name)
67 (assert (equal *gf/ri-args* '(:name name)))
68 (setf (generic-function-name gf) 'gf/ri)
69 (assert (equal *gf/ri-args* '(:name gf/ri)))))
71 (defgeneric gf/dependent ())
72 (defmethod update-dependent ((object standard-generic-function)
75 (setf (dependent-slot dependent) args))
76 (with-test (:name ((setf generic-function-name) update-dependent))
77 (let ((gf (find-class 'class/dependent)))
78 (add-dependent gf *dependent*)
79 (setf (generic-function-name gf) 'gf/name)
80 (assert (equal (dependent-slot *dependent*) '(:name gf/name)))
81 (remove-dependent gf *dependent*)
82 (setf (generic-function-name gf) 'gf/dependent)
83 (assert (equal (dependent-slot *dependent*) '(:name gf/name)))))