0.8.17.17:
[sbcl.git] / tests / mop-2.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 ;;;; Note that the MOP is not in an entirely supported state.
15 ;;;; However, this seems a good a way as any of ensuring that we have
16 ;;;; no regressions.
17
18 ;;; This is basically the DYNAMIC-SLOT-CLASS example from AMOP, with
19 ;;; fixups for running in the full MOP rather than closette -- SLOTDs
20 ;;; instead of slot-names, and so on -- and :allocation :dynamic for
21 ;;; dynamic slots.
22
23 (untrace)
24
25 (defpackage "TEST" (:use "CL" "SB-MOP"))
26 (in-package "TEST")
27
28 (defclass dynamic-slot-class (standard-class) ())
29
30 (defmethod validate-superclass
31     ((class dynamic-slot-class) (super standard-class))
32   t)
33
34 (defun dynamic-slot-p (slot)
35   (eq (slot-definition-allocation slot) :dynamic))
36
37 (let ((table (make-hash-table)))
38
39    (defun allocate-table-entry (instance)
40      (setf (gethash instance table) ()))
41
42    (defun read-dynamic-slot-value (instance slot-name)
43      (let* ((alist (gethash instance table))
44             (entry (assoc slot-name alist)))
45         (if (null entry)
46             (error "slot ~S unbound in ~S" slot-name instance)
47             (cdr entry))))
48
49    (defun write-dynamic-slot-value (new-value instance slot-name)
50       (let* ((alist (gethash instance table))
51              (entry (assoc slot-name alist)))
52          (if (null entry)
53              (push `(,slot-name . ,new-value)
54                    (gethash instance table))
55              (setf (cdr entry) new-value))
56          new-value))
57
58    (defun dynamic-slot-boundp (instance slot-name)
59       (let* ((alist (gethash instance table))
60              (entry (assoc slot-name alist)))
61         (not (null entry))))
62
63    (defun dynamic-slot-makunbound (instance slot-name)
64       (let* ((alist (gethash instance table))
65              (entry (assoc slot-name alist)))
66         (unless (null entry)
67           (setf (gethash instance table) (delete entry alist))))
68       instance)
69
70 )
71
72 (defmethod allocate-instance ((class dynamic-slot-class) &key)
73   (let ((instance (call-next-method)))
74     (allocate-table-entry instance)
75     instance))
76
77 (defmethod slot-value-using-class ((class dynamic-slot-class)
78                                    instance slotd)
79   (let ((slot (find slotd (class-slots class))))
80     (if (and slot (dynamic-slot-p slot))
81         (read-dynamic-slot-value instance (slot-definition-name slotd))
82         (call-next-method))))
83
84 (defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-class)
85                                           instance slotd)
86   (let ((slot (find slotd (class-slots class))))
87     (if (and slot (dynamic-slot-p slot))
88         (write-dynamic-slot-value new-value instance (slot-definition-name slotd))
89         (call-next-method))))
90
91 (defmethod slot-boundp-using-class ((class dynamic-slot-class)
92                                     instance slotd)
93   (let ((slot (find slotd (class-slots class))))
94     (if (and slot (dynamic-slot-p slot))
95         (dynamic-slot-boundp instance (slot-definition-name slotd))
96         (call-next-method))))
97
98 (defmethod slot-makunbound-using-class ((class dynamic-slot-class)
99                                         instance slotd)
100   (let ((slot (find slotd (class-slots class))))
101     (if (and slot (dynamic-slot-p slot))
102         (dynamic-slot-makunbound instance (slot-definition-name slotd))
103         (call-next-method))))
104
105 (defclass test-class-1 ()
106   ((slot1 :initarg :slot1 :allocation :dynamic)
107    (slot2 :initarg :slot2 :initform nil))
108   (:metaclass dynamic-slot-class))
109
110 (defclass test-class-2 (test-class-1)
111   ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
112    (slot3 :initarg :slot3))
113   (:metaclass dynamic-slot-class))
114
115 (defvar *one* (make-instance 'test-class-1))
116 (defvar *two* (make-instance 'test-class-2 :slot3 1))
117
118 (assert (not (slot-boundp *one* 'slot1)))
119 (assert (null (slot-value *one* 'slot2)))
120 (assert (eq t (slot-value *two* 'slot2)))
121 (assert (= 1 (slot-value *two* 'slot3)))
122
123 ;;; breakage observed by R. Mattes sbcl-help 2004-09-16, caused by
124 ;;; overconservatism in accessing a class's precedence list deep in
125 ;;; the bowels of COMPUTE-APPLICABLE-METHODS, during the process of
126 ;;; finalizing a class.
127 (defclass dynamic-slot-subclass (dynamic-slot-class) ())
128
129 (defmethod slot-value-using-class ((class dynamic-slot-subclass)
130                                    instance slotd)
131   (let ((slot (find slotd (class-slots class))))
132     (if (and slot (dynamic-slot-p slot))
133         (read-dynamic-slot-value instance (slot-definition-name slotd))
134         (call-next-method))))
135
136 (defmethod (setf slot-value-using-class) (new-value
137                                           (class dynamic-slot-subclass)
138                                           instance slotd)
139   (let ((slot (find slotd (class-slots class))))
140     (if (and slot (dynamic-slot-p slot))
141         (write-dynamic-slot-value new-value instance (slot-definition-name slotd))
142         (call-next-method))))
143
144 (defmethod slot-boundp-using-class ((class dynamic-slot-subclass)
145                                     instance slotd)
146   (let ((slot (find slotd (class-slots class))))
147     (if (and slot (dynamic-slot-p slot))
148         (dynamic-slot-boundp instance (slot-definition-name slotd))
149         (call-next-method))))
150
151 (defclass test-class-3 (test-class-1)
152   ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
153    (slot3 :initarg :slot3))
154   (:metaclass dynamic-slot-subclass))
155
156 (defvar *three* (make-instance 'test-class-3 :slot3 3))
157 (assert (not (slot-boundp *three* 'slot1)))
158 (assert (eq (slot-value *three* 'slot2) t))
159 (assert (= (slot-value *three* 'slot3) 3))