Add :application-type parameter for save-lisp-and-die on Windows.
[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-names (instance)
59     (mapcar #'car (gethash instance table)))
60
61    (defun dynamic-slot-boundp (instance slot-name)
62       (let* ((alist (gethash instance table))
63              (entry (assoc slot-name alist)))
64         (not (null entry))))
65
66    (defun dynamic-slot-makunbound (instance slot-name)
67       (let* ((alist (gethash instance table))
68              (entry (assoc slot-name alist)))
69         (unless (null entry)
70           (setf (gethash instance table) (delete entry alist))))
71       instance)
72 )
73
74 (defmethod allocate-instance ((class dynamic-slot-class) &key)
75   (let ((instance (call-next-method)))
76     (allocate-table-entry instance)
77     instance))
78
79 (defmethod slot-value-using-class ((class dynamic-slot-class)
80                                    instance slotd)
81   (let ((slot (find slotd (class-slots class))))
82     (if (and slot (dynamic-slot-p slot))
83         (read-dynamic-slot-value instance (slot-definition-name slotd))
84         (call-next-method))))
85
86 (defmethod (setf slot-value-using-class) (new-value (class dynamic-slot-class)
87                                           instance slotd)
88   (let ((slot (find slotd (class-slots class))))
89     (if (and slot (dynamic-slot-p slot))
90         (write-dynamic-slot-value new-value instance (slot-definition-name slotd))
91         (call-next-method))))
92
93 (defmethod slot-boundp-using-class ((class dynamic-slot-class)
94                                     instance slotd)
95   (let ((slot (find slotd (class-slots class))))
96     (if (and slot (dynamic-slot-p slot))
97         (dynamic-slot-boundp instance (slot-definition-name slotd))
98         (call-next-method))))
99
100 (defmethod slot-makunbound-using-class ((class dynamic-slot-class)
101                                         instance slotd)
102   (let ((slot (find slotd (class-slots class))))
103     (if (and slot (dynamic-slot-p slot))
104         (dynamic-slot-makunbound instance (slot-definition-name slotd))
105         (call-next-method))))
106
107 (defclass test-class-1 ()
108   ((slot1 :initarg :slot1 :allocation :dynamic)
109    (slot2 :initarg :slot2 :initform nil))
110   (:metaclass dynamic-slot-class))
111
112 (defclass test-class-2 (test-class-1)
113   ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
114    (slot3 :initarg :slot3))
115   (:metaclass dynamic-slot-class))
116
117 (defvar *one* (make-instance 'test-class-1))
118 (defvar *two* (make-instance 'test-class-2 :slot3 1))
119
120 (assert (not (slot-boundp *one* 'slot1)))
121 (assert (null (slot-value *one* 'slot2)))
122 (assert (eq t (slot-value *two* 'slot2)))
123 (assert (= 1 (slot-value *two* 'slot3)))
124
125 ;;; breakage observed by R. Mattes sbcl-help 2004-09-16, caused by
126 ;;; overconservatism in accessing a class's precedence list deep in
127 ;;; the bowels of COMPUTE-APPLICABLE-METHODS, during the process of
128 ;;; finalizing a class.
129 (defclass dynamic-slot-subclass (dynamic-slot-class) ())
130
131 (defmethod slot-value-using-class ((class dynamic-slot-subclass)
132                                    instance slotd)
133   (let ((slot (find slotd (class-slots class))))
134     (if (and slot (dynamic-slot-p slot))
135         (read-dynamic-slot-value instance (slot-definition-name slotd))
136         (call-next-method))))
137
138 (defmethod (setf slot-value-using-class) (new-value
139                                           (class dynamic-slot-subclass)
140                                           instance slotd)
141   (let ((slot (find slotd (class-slots class))))
142     (if (and slot (dynamic-slot-p slot))
143         (write-dynamic-slot-value new-value instance (slot-definition-name slotd))
144         (call-next-method))))
145
146 (defmethod slot-boundp-using-class ((class dynamic-slot-subclass)
147                                     instance slotd)
148   (let ((slot (find slotd (class-slots class))))
149     (if (and slot (dynamic-slot-p slot))
150         (dynamic-slot-boundp instance (slot-definition-name slotd))
151         (call-next-method))))
152
153 (defclass test-class-3 (test-class-1)
154   ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
155    (slot3 :initarg :slot3))
156   (:metaclass dynamic-slot-subclass))
157
158 (defvar *three* (make-instance 'test-class-3 :slot3 3))
159 (assert (not (slot-boundp *three* 'slot1)))
160 (assert (eq (slot-value *three* 'slot2) t))
161 (assert (= (slot-value *three* 'slot3) 3))
162
163 (defmethod slot-missing ((class dynamic-slot-class) instance slot-name operation &optional v)
164   (declare (ignore v))
165   (list :slot-missing slot-name))
166
167 ;;; Test redefinition adding a dynamic slot
168 (defclass test-class-3 (test-class-1)
169   ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
170    (slot3 :initarg :slot3)
171    (slot4 :initarg :slot4 :initform 42 :allocation :dynamic))
172   (:metaclass dynamic-slot-subclass))
173 (assert (= 42 (slot-value *three* 'slot4)))
174
175 ;;; Test redefinition removing a dynamic slot
176 (defclass test-class-3 (test-class-1)
177   ((slot2 :initarg :slot2 :initform t :allocation :dynamic)
178    (slot3 :initarg :slot3))
179   (:metaclass dynamic-slot-subclass))
180 (assert (equal (list :slot-missing 'slot4) (slot-value *three* 'slot4)))
181
182 ;;; Test redefinition making a dynamic slot local
183 ;;;
184 ;;; NOTE: seriously underspecified. We muddle somehow.
185 (defclass test-class-3 (test-class-1)
186   ((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
187    (slot3 :initarg :slot3))
188   (:metaclass dynamic-slot-subclass))
189 (let* ((slots (class-slots (find-class 'test-class-3)))
190        (slot (find 'slot2 slots :key #'slot-definition-name)))
191   (assert (eq :instance (slot-definition-allocation slot)))
192   (assert (eq 'ok (slot-value *three* 'slot2))))
193
194 ;;; Test redefinition making a local slot dynamic again
195 ;;;
196 ;;; NOTE: seriously underspecified. We muddle somehow.
197 ;;; This picks up the old value from the table, not the
198 ;;; new initform.
199 (defclass test-class-3 (test-class-1)
200   ((slot2 :initarg :slot2 :initform 'ok? :allocation :dynamic)
201    (slot3 :initarg :slot3))
202   (:metaclass dynamic-slot-subclass))
203 (let* ((slots (class-slots (find-class 'test-class-3)))
204        (slot (find 'slot2 slots :key #'slot-definition-name)))
205   (assert (eq :dynamic (slot-definition-allocation slot)))
206   (assert (eq t (slot-value *three* 'slot2))))
207
208 ;;; Test redefinition making a dynamic slot local, with
209 ;;; UPDATE-INSTANCE-FOR-REDEFINED-CLASS unbinding the dynamic slot.
210 ;;; Then we make it dynamic again.
211 ;;;
212 ;;; NOTE: seriously underspecified. We muddle somehow.
213 (defmethod update-instance-for-redefined-class :after ((obj test-class-3) add drop plist
214                                                        &rest inits)
215   (declare (ignore inits))
216   (let* ((class (class-of obj))
217          (slots (class-slots class)))
218     (dolist (name (dynamic-slot-names obj))
219       (let ((slotd (find name slots :key #'slot-definition-name)))
220         (unless (and slotd (eq :dynamic (slot-definition-allocation slotd)))
221           (dynamic-slot-makunbound obj name))))))
222 (defclass test-class-3 (test-class-1)
223   ((slot2 :initarg :slot2 :initform 'ok :allocation :instance)
224    (slot3 :initarg :slot3))
225   (:metaclass dynamic-slot-subclass))
226 (let* ((slots (class-slots (find-class 'test-class-3)))
227        (slot (find 'slot2 slots :key #'slot-definition-name)))
228   (assert (eq :instance (slot-definition-allocation slot)))
229   (assert (eq 'ok (slot-value *three* 'slot2))))
230 (defclass test-class-3 (test-class-1)
231   ((slot2 :initarg :slot2 :initform 'ok! :allocation :dynamic)
232    (slot3 :initarg :slot3))
233   (:metaclass dynamic-slot-subclass))
234 (let* ((slots (class-slots (find-class 'test-class-3)))
235        (slot (find 'slot2 slots :key #'slot-definition-name)))
236   (assert (eq :dynamic (slot-definition-allocation slot)))
237   (assert (eq 'ok! (slot-value *three* 'slot2))))