38 |
|
|
39 |
;; Definitions of methods |
;; Definitions of methods |
40 |
|
|
41 |
(defmethod make-instance ((x (eql 'foo)) &rest initargs &key &allow-other-keys) |
(defmethod make-instance ((x make-instance-class-01) |
42 |
(cons x initargs)) |
&rest initargs &key &allow-other-keys) |
43 |
|
initargs) |
44 |
|
|
45 |
(deftest make-instance.1 |
(deftest make-instance.1 |
46 |
(make-instance 'foo) |
(make-instance (make-instance 'make-instance-class-01)) |
|
(foo)) |
|
|
|
|
|
(deftest make-instance.2 |
|
|
(make-instance 'foo :a 1 :b 2) |
|
|
(foo :a 1 :b 2)) |
|
|
|
|
|
(defclass make-instance-class-02 () |
|
|
(a b c)) |
|
|
|
|
|
(defmethod make-instance ((class (eql (find-class 'make-instance-class-02))) |
|
|
&rest initargs &key (x nil) (y nil) (z nil) |
|
|
&allow-other-keys) |
|
|
(declare (ignore initargs)) |
|
|
(let ((obj (allocate-instance class))) |
|
|
(setf (slot-value obj 'a) x |
|
|
(slot-value obj 'b) y |
|
|
(slot-value obj 'c) z) |
|
|
obj)) |
|
|
|
|
|
(deftest make-instance.3 |
|
|
(let ((obj (make-instance 'make-instance-class-02))) |
|
|
(values |
|
|
(eqt (class-of obj) (find-class 'make-instance-class-02)) |
|
|
(slot-value obj 'a) |
|
|
(slot-value obj 'b) |
|
|
(slot-value obj 'c))) |
|
|
t nil nil nil) |
|
|
|
|
|
(deftest make-instance.4 |
|
|
(let ((obj (make-instance 'make-instance-class-02 :z 10 :y 45 :x 'd))) |
|
|
(values |
|
|
(eqt (class-of obj) (find-class 'make-instance-class-02)) |
|
|
(slot-value obj 'a) |
|
|
(slot-value obj 'b) |
|
|
(slot-value obj 'c))) |
|
|
t d 45 10) |
|
|
|
|
|
|
|
|
(deftest make-instance.5 |
|
|
(let ((obj (make-instance (find-class 'make-instance-class-02) :y 'g))) |
|
|
(values |
|
|
(eqt (class-of obj) (find-class 'make-instance-class-02)) |
|
|
(slot-value obj 'a) |
|
|
(slot-value obj 'b) |
|
|
(slot-value obj 'c))) |
|
|
t nil g nil) |
|
|
|
|
|
(deftest make-instance.6 |
|
|
(eq (make-instance 'make-instance-class-02) |
|
|
(make-instance 'make-instance-class-02)) |
|
47 |
nil) |
nil) |
48 |
|
|
49 |
;; Customization of make-instance |
(deftest make-instance.2 |
50 |
|
(make-instance (make-instance 'make-instance-class-01) :a 1 :b 2) |
51 |
(defclass make-instance-class-03 () |
(:a 1 :b 2)) |
|
((a :initform 1) (b :initarg :b) c)) |
|
52 |
|
|
53 |
(defmethod make-instance ((class (eql (find-class 'make-instance-class-03))) |
#| |
54 |
&rest initargs |
(when *can-define-metaclasses* |
55 |
&key (x nil x-p) (y nil y-p) (z nil z-p) |
|
56 |
&allow-other-keys) |
(defclass make-instance-class-02 () |
57 |
(declare (ignore initargs)) |
(a b c) |
58 |
(let ((obj (allocate-instance (find-class 'make-instance-class-03)))) |
(:metaclass substandard-class)) |
59 |
(when x-p (setf (slot-value obj 'a) x)) |
|
60 |
(when y-p (setf (slot-value obj 'b) y)) |
(defmethod make-instance ((class (eql (find-class 'make-instance-class-02))) |
61 |
(when z-p (setf (slot-value obj 'c) z)) |
&rest initargs &key (x nil) (y nil) (z nil) |
62 |
obj)) |
&allow-other-keys) |
63 |
|
(declare (ignore initargs)) |
64 |
(deftest make-instance.7 |
(let ((obj (allocate-instance class))) |
65 |
(let ((obj (make-instance 'make-instance-class-03))) |
(setf (slot-value obj 'a) x |
66 |
(values |
(slot-value obj 'b) y |
67 |
(eqt (class-of obj) |
(slot-value obj 'c) z) |
68 |
(find-class 'make-instance-class-03)) |
obj)) |
69 |
(map-slot-boundp* obj '(a b c)))) |
|
70 |
t (nil nil nil)) |
(deftest make-instance.3 |
71 |
|
(let ((obj (make-instance 'make-instance-class-02))) |
72 |
(deftest make-instance.8 |
(values |
73 |
(let* ((class (find-class 'make-instance-class-03)) |
(eqt (class-of obj) (find-class 'make-instance-class-02)) |
74 |
(obj (make-instance class :b 10))) |
(slot-value obj 'a) |
75 |
(values |
(slot-value obj 'b) |
76 |
(eqt (class-of obj) class) |
(slot-value obj 'c))) |
77 |
(map-slot-boundp* obj '(a b c)))) |
t nil nil nil) |
78 |
t (nil nil nil)) |
|
79 |
|
(deftest make-instance.4 |
80 |
(deftest make-instance.9 |
(let ((obj (make-instance 'make-instance-class-02 :z 10 :y 45 :x 'd))) |
81 |
(let* ((class (find-class 'make-instance-class-03)) |
(values |
82 |
(obj (make-instance class :x 'g :z 'i :y 'k :foo t :x 'bad))) |
(eqt (class-of obj) (find-class 'make-instance-class-02)) |
83 |
(values |
(slot-value obj 'a) |
84 |
(eqt (class-of obj) class) |
(slot-value obj 'b) |
85 |
(map-slot-boundp* obj '(a b c)) |
(slot-value obj 'c))) |
86 |
(map-slot-value obj '(a b c)))) |
t d 45 10) |
87 |
t (t t t) (g k i)) |
|
88 |
|
|
89 |
;;; After method combination |
(deftest make-instance.5 |
90 |
|
(let ((obj (make-instance (find-class 'make-instance-class-02) :y 'g))) |
91 |
(defparameter *make-instance-class-04-var* 0) |
(values |
92 |
|
(eqt (class-of obj) (find-class 'make-instance-class-02)) |
93 |
(defclass make-instance-class-04 () |
(slot-value obj 'a) |
94 |
((a :initform *make-instance-class-04-var*))) |
(slot-value obj 'b) |
95 |
|
(slot-value obj 'c))) |
96 |
(defmethod make-instance :after |
t nil g nil) |
97 |
((class (eql (find-class 'make-instance-class-04))) |
|
98 |
&rest initargs &key &allow-other-keys) |
(deftest make-instance.6 |
99 |
(declare (ignore initargs)) |
(eq (make-instance 'make-instance-class-02) |
100 |
(incf *make-instance-class-04-var* 10)) |
(make-instance 'make-instance-class-02)) |
101 |
|
nil) |
102 |
(deftest make-instance.10 |
|
103 |
(let* ((*make-instance-class-04-var* 0) |
;; Customization of make-instance |
104 |
(obj (make-instance 'make-instance-class-04))) |
|
105 |
(values |
(defclass make-instance-class-03 () |
106 |
(slot-value obj 'a) |
((a :initform 1) (b :initarg :b) c) |
107 |
*make-instance-class-04-var*)) |
(:metaclass substandard-class)) |
108 |
0 10) |
|
109 |
|
(defmethod make-instance ((class (eql (find-class 'make-instance-class-03))) |
110 |
;;; Around method combination |
&rest initargs |
111 |
|
&key (x nil x-p) (y nil y-p) (z nil z-p) |
112 |
(defclass make-instance-class-05 () |
&allow-other-keys) |
113 |
((a :initarg :a) (b :initarg :b :initform 'foo) c)) |
(declare (ignore initargs)) |
114 |
|
(let ((obj (allocate-instance (find-class 'make-instance-class-03)))) |
115 |
(defmethod make-instance :around |
(when x-p (setf (slot-value obj 'a) x)) |
116 |
((class (eql (find-class 'make-instance-class-05))) |
(when y-p (setf (slot-value obj 'b) y)) |
117 |
&rest initargs &key &allow-other-keys) |
(when z-p (setf (slot-value obj 'c) z)) |
118 |
(declare (ignore initargs)) |
obj)) |
119 |
(let ((obj (call-next-method))) |
|
120 |
(setf (slot-value obj 'c) 'bar) |
(deftest make-instance.7 |
121 |
obj)) |
(let ((obj (make-instance 'make-instance-class-03))) |
122 |
|
(values |
123 |
(deftest make-instance.11 |
(eqt (class-of obj) |
124 |
(let ((obj (make-instance 'make-instance-class-05))) |
(find-class 'make-instance-class-03)) |
125 |
(values |
(map-slot-boundp* obj '(a b c)))) |
126 |
(map-slot-boundp* obj '(a b c)) |
t (nil nil nil)) |
127 |
(map-slot-value obj '(b c)))) |
|
128 |
(nil t t) |
(deftest make-instance.8 |
129 |
(foo bar)) |
(let* ((class (find-class 'make-instance-class-03)) |
130 |
|
(obj (make-instance class :b 10))) |
131 |
|
(values |
132 |
|
(eqt (class-of obj) class) |
133 |
|
(map-slot-boundp* obj '(a b c)))) |
134 |
|
t (nil nil nil)) |
135 |
|
|
136 |
|
(deftest make-instance.9 |
137 |
|
(let* ((class (find-class 'make-instance-class-03)) |
138 |
|
(obj (make-instance class :x 'g :z 'i :y 'k :foo t :x 'bad))) |
139 |
|
(values |
140 |
|
(eqt (class-of obj) class) |
141 |
|
(map-slot-boundp* obj '(a b c)) |
142 |
|
(map-slot-value obj '(a b c)))) |
143 |
|
t (t t t) (g k i)) |
144 |
|
|
145 |
|
;; After method combination |
146 |
|
|
147 |
|
(defparameter *make-instance-class-04-var* 0) |
148 |
|
|
149 |
|
(defclass make-instance-class-04 () |
150 |
|
((a :initform *make-instance-class-04-var*)) |
151 |
|
(:metaclass substandard-class)) |
152 |
|
|
153 |
|
(defmethod make-instance :after |
154 |
|
((class (eql (find-class 'make-instance-class-04))) |
155 |
|
&rest initargs &key &allow-other-keys) |
156 |
|
(declare (ignore initargs)) |
157 |
|
(incf *make-instance-class-04-var* 10)) |
158 |
|
|
159 |
|
(deftest make-instance.10 |
160 |
|
(let* ((*make-instance-class-04-var* 0) |
161 |
|
(obj (make-instance 'make-instance-class-04))) |
162 |
|
(values |
163 |
|
(slot-value obj 'a) |
164 |
|
*make-instance-class-04-var*)) |
165 |
|
0 10) |
166 |
|
|
167 |
|
;; Around method combination |
168 |
|
|
169 |
|
(defclass make-instance-class-05 () |
170 |
|
((a :initarg :a) (b :initarg :b :initform 'foo) c) |
171 |
|
(:metaclass substandard-class)) |
172 |
|
|
173 |
|
(defmethod make-instance :around |
174 |
|
((class (eql (find-class 'make-instance-class-05))) |
175 |
|
&rest initargs &key &allow-other-keys) |
176 |
|
(declare (ignore initargs)) |
177 |
|
(let ((obj (call-next-method))) |
178 |
|
(setf (slot-value obj 'c) 'bar) |
179 |
|
obj)) |
180 |
|
|
181 |
|
(deftest make-instance.11 |
182 |
|
(let ((obj (make-instance 'make-instance-class-05))) |
183 |
|
(values |
184 |
|
(map-slot-boundp* obj '(a b c)) |
185 |
|
(map-slot-value obj '(b c)))) |
186 |
|
(nil t t) |
187 |
|
(foo bar)) |
188 |
|
) |
189 |
|
|# |
190 |
|
|
191 |
;;; Order of argument evaluation |
;;; Order of argument evaluation |
192 |
|
|