1.0.23.21: Stack allocated conses for MIPS.
[sbcl.git] / tests / mop-9.impure-cload.lisp
1 ;;;; miscellaneous side-effectful tests of the MOP
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;;
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.
13
14 ;;; this file contains tests of (SETF CLASS-NAME) and (SETF
15 ;;; GENERIC-FUNCTION-NAME)
16
17 (defpackage "MOP-9"
18   (:use "CL" "SB-MOP" "TEST-UTIL"))
19
20 (in-package "MOP-9")
21
22 (defclass metaclass/ri (standard-class)
23   ())
24 (defmethod validate-superclass ((c metaclass/ri) (s standard-class))
25   t)
26 (defclass class/ri ()
27   ()
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)))))
38
39 (defclass dependent ()
40   ((slot :initform nil :accessor dependent-slot)))
41 (defclass class/dependent ()
42   ())
43 (defvar *dependent* (make-instance 'dependent))
44 (defmethod update-dependent ((object standard-class) (dependent dependent)
45                              &rest args)
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)))))
55
56 (defclass gfc/ri (standard-generic-function)
57   ()
58   (:metaclass funcallable-standard-class))
59 (defgeneric gf/ri ()
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))
65   (let ((gf #'gf/ri))
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)))))
70
71 (defgeneric gf/dependent ())
72 (defmethod update-dependent ((object standard-generic-function)
73                              (dependent dependent)
74                              &rest args)
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)))))