1.0.23.21: Stack allocated conses for MIPS.
[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 (defpackage "CTOR-TEST"
15   (:use "CL"))
16
17 (in-package "CTOR-TEST")
18 \f
19 (defclass no-slots () ())
20
21 (defun make-no-slots ()
22   (make-instance 'no-slots))
23 (compile 'make-no-slots)
24
25 (defmethod update-instance-for-redefined-class
26     ((object no-slots) added discarded plist &rest initargs)
27   (declare (ignore initargs))
28   (error "Called U-I-F-R-C on ~A" object))
29
30 (assert (typep (make-no-slots) 'no-slots))
31
32 (make-instances-obsolete 'no-slots)
33
34 (assert (typep (make-no-slots) 'no-slots))
35 (assert (typep (funcall #'(sb-pcl::ctor no-slots nil)) 'no-slots))
36 \f
37 (defclass one-slot ()
38   ((a :initarg :a)))
39
40 (defun make-one-slot-a (a)
41   (make-instance 'one-slot :a a))
42 (compile 'make-one-slot-a)
43 (defun make-one-slot-noa ()
44   (make-instance 'one-slot))
45 (compile 'make-one-slot-noa)
46
47 (defmethod update-instance-for-redefined-class
48     ((object one-slot) added discarded plist &rest initargs)
49   (declare (ignore initargs))
50   (error "Called U-I-F-R-C on ~A" object))
51
52 (assert (= (slot-value (make-one-slot-a 3) 'a) 3))
53 (assert (not (slot-boundp (make-one-slot-noa) 'a)))
54
55 (make-instances-obsolete 'one-slot)
56
57 (assert (= (slot-value (make-one-slot-a 3) 'a) 3))
58 (assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot nil :a sb-pcl::\.p0.) 4) 'a) 4))
59 (assert (not (slot-boundp (make-one-slot-noa) 'a)))
60 (assert (not (slot-boundp (funcall #'(sb-pcl::ctor one-slot nil)) 'a)))
61 \f
62 (defclass one-slot-superclass ()
63   ((b :initarg :b)))
64 (defclass one-slot-subclass (one-slot-superclass)
65   ())
66
67 (defun make-one-slot-subclass (b)
68   (make-instance 'one-slot-subclass :b b))
69 (compile 'make-one-slot-subclass)
70
71 (defmethod update-instance-for-redefined-class
72     ((object one-slot-superclass) added discarded plist &rest initargs)
73   (declare (ignore initargs))
74   (error "Called U-I-F-R-C on ~A" object))
75
76 (assert (= (slot-value (make-one-slot-subclass 2) 'b) 2))
77
78 (make-instances-obsolete 'one-slot-subclass)
79
80 (assert (= (slot-value (make-one-slot-subclass 2) 'b) 2))
81 (assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot-subclass nil :b sb-pcl::\.p0.) 3) 'b) 3))
82 (make-instances-obsolete 'one-slot-superclass)
83
84 (assert (= (slot-value (make-one-slot-subclass 2) 'b) 2))
85 (assert (= (slot-value (funcall #'(sb-pcl::ctor one-slot-subclass nil :b sb-pcl::\.p0.) 4) 'b) 4))
86 \f
87 ;;;; success