Really restore clisp cross-compilation.
[sbcl.git] / tests / ctor.impure.lisp
1 ;;;; gray-box testing of the constructor optimization machinery
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 (load "test-util.lisp")
15 (load "compiler-test-util.lisp")
16
17 (defpackage "CTOR-TEST"
18   (:use "CL" "TEST-UTIL" "COMPILER-TEST-UTIL"))
19
20 (in-package "CTOR-TEST")
21 \f
22 (defclass no-slots () ())
23
24 (defun make-no-slots ()
25   (make-instance 'no-slots))
26 (compile 'make-no-slots)
27
28 (defmethod update-instance-for-redefined-class
29     ((object no-slots) added discarded plist &rest initargs)
30   (declare (ignore initargs))
31   (error "Called U-I-F-R-C on ~A" object))
32
33 (assert (typep (make-no-slots) 'no-slots))
34
35 (make-instances-obsolete 'no-slots)
36
37 (assert (typep (make-no-slots) 'no-slots))
38 (assert (typep (funcall #'(sb-pcl::ctor no-slots nil)) 'no-slots))
39 \f
40 (defclass one-slot ()
41   ((a :initarg :a)))
42
43 (defun make-one-slot-a (a)
44   (make-instance 'one-slot :a a))
45 (compile 'make-one-slot-a)
46 (defun make-one-slot-noa ()
47   (make-instance 'one-slot))
48 (compile 'make-one-slot-noa)
49
50 (defmethod update-instance-for-redefined-class
51     ((object one-slot) added discarded plist &rest initargs)
52   (declare (ignore initargs))
53   (error "Called U-I-F-R-C on ~A" object))
54
55 (assert (= (slot-value (make-one-slot-a 3) 'a) 3))
56 (assert (not (slot-boundp (make-one-slot-noa) 'a)))
57
58 (make-instances-obsolete 'one-slot)
59
60 (assert (= (slot-value (make-one-slot-a 3) 'a) 3))
61 (assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot nil :a sb-pcl::\.p0.) 4) 'a) 4))
62 (assert (not (slot-boundp (make-one-slot-noa) 'a)))
63 (assert (not (slot-boundp (funcall #'(sb-pcl::ctor one-slot nil)) 'a)))
64 \f
65 (defclass one-slot-superclass ()
66   ((b :initarg :b)))
67 (defclass one-slot-subclass (one-slot-superclass)
68   ())
69
70 (defun make-one-slot-subclass (b)
71   (make-instance 'one-slot-subclass :b b))
72 (compile 'make-one-slot-subclass)
73
74 (defmethod update-instance-for-redefined-class
75     ((object one-slot-superclass) added discarded plist &rest initargs)
76   (declare (ignore initargs))
77   (error "Called U-I-F-R-C on ~A" object))
78
79 (assert (= (slot-value (make-one-slot-subclass 2) 'b) 2))
80
81 (make-instances-obsolete 'one-slot-subclass)
82
83 (assert (= (slot-value (make-one-slot-subclass 2) 'b) 2))
84 (assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot-subclass nil :b sb-pcl::\.p0.) 3) 'b) 3))
85 (make-instances-obsolete 'one-slot-superclass)
86
87 (assert (= (slot-value (make-one-slot-subclass 2) 'b) 2))
88 (assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot-subclass nil :b sb-pcl::\.p0.) 4) 'b) 4))
89
90 ;;; Tests for CTOR optimization of non-constant class args and constant class object args
91 (defun find-ctor-caches (fun)
92   (remove-if-not (lambda (value)
93                    (and (consp value) (eq 'sb-pcl::ctor-cache (car value))))
94                  (find-value-cell-values fun)))
95
96 (let* ((cmacro (compiler-macro-function 'make-instance))
97         (opt 0)
98         (wrapper (lambda (form env)
99                    (let ((res (funcall cmacro form env)))
100                      (unless (eq form res)
101                        (incf opt))
102                      res))))
103    (sb-ext:without-package-locks
104      (unwind-protect
105           (progn
106             (setf (compiler-macro-function 'make-instance) wrapper)
107             (with-test (:name (make-instance :non-constant-class))
108               (assert (= 0 opt))
109               (let ((f (compile nil `(lambda (class)
110                                        (make-instance class :b t)))))
111                 (assert (= 1 (length (find-ctor-caches f))))
112                 (assert (= 1 opt))
113                 (assert (typep (funcall f 'one-slot-subclass) 'one-slot-subclass))))
114             (with-test (:name (make-instance :constant-class-object))
115               (let ((f (compile nil `(lambda ()
116                                        (make-instance ,(find-class 'one-slot-subclass) :b t)))))
117                 (assert (not (find-ctor-caches f)))
118                 (assert (= 2 opt))
119                 (assert (typep (funcall f) 'one-slot-subclass))))
120             (with-test (:name (make-instance :constant-non-std-class-object))
121               (let ((f (compile nil `(lambda ()
122                                        (make-instance ,(find-class 'structure-object))))))
123                 (assert (not (find-ctor-caches f)))
124                 (assert (= 3 opt))
125                 (assert (typep (funcall f) 'structure-object))))
126             (with-test (:name (make-instance :constant-non-std-class-name))
127               (let ((f (compile nil `(lambda ()
128                                        (make-instance 'structure-object)))))
129                 (assert (not (find-ctor-caches f)))
130                 (assert (= 4 opt))
131                 (assert (typep (funcall f) 'structure-object)))))
132        (setf (compiler-macro-function 'make-instance) cmacro))))
133
134 (with-test (:name (make-instance :ctor-inline-cache-resize))
135   (let* ((f (compile nil `(lambda (name) (make-instance name))))
136          (classes (loop repeat (* 2 sb-pcl::+ctor-table-max-size+)
137                         collect (class-name (eval `(defclass ,(gentemp) () ())))))
138          (count 0)
139          (caches (find-ctor-caches f))
140          (cache (pop caches)))
141     (assert cache)
142     (assert (not caches))
143     (assert (not (cdr cache)))
144     (dolist (class classes)
145       (assert (typep (funcall f (if (oddp count) class (find-class class))) class))
146       (incf count)
147       (cond ((<= count sb-pcl::+ctor-list-max-size+)
148              (unless (consp (cdr cache))
149                (error "oops, wanted list cache, got: ~S" cache))
150              (unless (= count (length (cdr cache)))
151                (error "oops, wanted ~S elts in cache, got: ~S" count cache)))
152             (t
153              (assert (simple-vector-p (cdr cache))))))
154     (dolist (class classes)
155       (assert (typep (funcall f (if (oddp count) class (find-class class))) class))
156       (incf count))))
157
158 ;;; Make sure we get default initargs right with on the FAST-MAKE-INSTANCE path CTORs
159 (defclass some-class ()
160   ((aroundp :initform nil :reader aroundp))
161   (:default-initargs :x :success1))
162
163 (defmethod shared-initialize :around ((some-class some-class) slots &key (x :fail?))
164   (unless (eq x :success1)
165     (error "Default initarg lossage"))
166   (setf (slot-value some-class 'aroundp) t)
167   (when (next-method-p)
168     (call-next-method)))
169
170 (with-test (:name (make-instance :ctor-default-initargs-1))
171   (assert (aroundp (eval `(make-instance 'some-class))))
172   (let ((fun (compile nil `(lambda () (make-instance 'some-class)))))
173     (assert (aroundp (funcall fun)))
174     ;; make sure we tested what we think we tested...
175     (let ((ctors (find-named-callees fun :type 'sb-pcl::ctor)))
176       (assert ctors)
177       (assert (not (cdr ctors)))
178       (assert (find-named-callees (car ctors) :name 'sb-pcl::fast-make-instance)))))
179
180 ;;; Make sure we get default initargs right with on the FAST-MAKE-INSTANCE path CTORs
181 ;;; in more interesting cases as well...
182 (defparameter *some-counter* 0)
183 (let* ((x 'success2))
184   (defclass some-class2 ()
185     ((aroundp :initform nil :reader aroundp))
186     (:default-initargs :x (progn (incf *some-counter*) x))))
187
188 (defmethod shared-initialize :around ((some-class some-class2) slots &key (x :fail2?))
189   (unless (eq x 'success2)
190     (error "Default initarg lossage"))
191   (setf (slot-value some-class 'aroundp) t)
192   (when (next-method-p)
193     (call-next-method)))
194
195 (with-test (:name (make-instance :ctor-default-initargs-2))
196   (assert (= 0 *some-counter*))
197   (assert (aroundp (eval `(make-instance 'some-class2))))
198   (assert (= 1 *some-counter*))
199   (let ((fun (compile nil `(lambda () (make-instance 'some-class2)))))
200     (assert (= 1 *some-counter*))
201     (assert (aroundp (funcall fun)))
202     (assert (= 2 *some-counter*))
203     ;; make sure we tested what we think we tested...
204     (let ((ctors (find-named-callees fun :type 'sb-pcl::ctor)))
205       (assert ctors)
206       (assert (not (cdr ctors)))
207       (assert (find-named-callees (car ctors) :name 'sb-pcl::fast-make-instance)))))
208
209 ;;; No compiler notes, please
210 (locally (declare (optimize safety))
211   (defclass type-check-thing ()
212     ((slot :type (integer 0) :initarg :slot))))
213 (with-test (:name (make-instance :no-compile-note-at-runtime))
214   (let ((fun (compile nil `(lambda (x)
215                              (declare (optimize safety))
216                              (make-instance 'type-check-thing :slot x)))))
217     (handler-bind ((sb-ext:compiler-note #'error))
218       (funcall fun 41)
219       (funcall fun 13))))
220
221 ;;; NO-APPLICABLE-METHOD called
222 (defmethod no-applicable-method ((gf (eql #'make-instance)) &rest args)
223   (cons :no-applicable-method args))
224 (with-test (:name :constant-invalid-class-arg)
225   (assert (equal
226            '(:no-applicable-method "FOO" :quux 14)
227            (funcall (compile nil `(lambda (x) (make-instance "FOO" :quux x))) 14)))
228   (assert (equal
229            '(:no-applicable-method 'abc zot 1 bar 2)
230            (funcall (compile nil `(lambda (x y) (make-instance ''abc 'zot x 'bar y)))
231                     1 2))))
232 (with-test (:name :variable-invalid-class-arg)
233   (assert (equal
234            '(:no-applicable-method "FOO" :quux 14)
235            (funcall (compile nil `(lambda (c x) (make-instance c :quux x))) "FOO" 14)))
236   (assert (equal
237            '(:no-applicable-method 'abc zot 1 bar 2)
238            (funcall (compile nil `(lambda (c x y) (make-instance c 'zot x 'bar y)))
239                     ''abc 1 2))))
240
241 (defclass sneaky-class (standard-class)
242   ())
243
244 (defmethod sb-mop:validate-superclass ((class sneaky-class) (super standard-class))
245   t)
246
247 (defclass sneaky ()
248   ((dirty :initform nil :accessor dirty-slots)
249    (a :initarg :a :reader sneaky-a)
250    (b :initform "b" :reader sneaky-b)
251    (c :accessor sneaky-c))
252   (:metaclass sneaky-class))
253
254 (defvar *supervising* nil)
255
256 (defmethod (setf sb-mop:slot-value-using-class)
257     :before (value (class sneaky-class) (instance sneaky) slotd)
258   (unless *supervising*
259     (let ((name (sb-mop:slot-definition-name slotd))
260           (*supervising* t))
261       (when (slot-boundp instance 'dirty)
262         (pushnew name (dirty-slots instance))))))
263
264 (with-test (:name (make-instance :setf-slot-value-using-class-hits-other-slots))
265   (let ((fun (compile nil `(lambda (a c)
266                              (let ((i (make-instance 'sneaky :a a)))
267                                (setf (sneaky-c i) c)
268                                i)))))
269     (loop repeat 3
270           do (let ((i (funcall fun "a" "c")))
271                (assert (equal '(c b a) (dirty-slots i)))
272                (assert (equal "a" (sneaky-a i)))
273                (assert (equal "b" (sneaky-b i)))
274                (assert (equal "c" (sneaky-c i)))))))
275
276 (defclass bug-728650-base ()
277   ((value
278     :initarg :value
279     :initform nil)))
280
281 (defmethod initialize-instance :after ((instance bug-728650-base) &key)
282   (with-slots (value) instance
283     (unless value
284       (error "Impossible! Value slot not initialized in ~S" instance))))
285
286 (defclass bug-728650-child-1 (bug-728650-base)
287   ())
288
289 (defmethod initialize-instance :around ((instance bug-728650-child-1) &rest initargs &key)
290   (apply #'call-next-method instance :value 'provided-by-child-1 initargs))
291
292 (defclass bug-728650-child-2 (bug-728650-base)
293   ())
294
295 (defmethod initialize-instance :around ((instance bug-728650-child-2) &rest initargs &key)
296   (let ((foo (make-instance 'bug-728650-child-1)))
297     (apply #'call-next-method instance :value foo initargs)))
298
299 (with-test (:name :bug-728650)
300   (let ((child1 (slot-value (make-instance 'bug-728650-child-2) 'value)))
301     (assert (typep child1 'bug-728650-child-1))
302     (assert (eq 'provided-by-child-1 (slot-value child1 'value)))))
303
304 \f
305 ;;;; success