95 |
(make-instance 'make-instance-class-02)) |
(make-instance 'make-instance-class-02)) |
96 |
nil) |
nil) |
97 |
|
|
98 |
|
;; Customization of make-instance |
99 |
|
|
100 |
|
(defclass make-instance-class-03 () |
101 |
|
((a :initform 1) (b :initarg :b) c)) |
102 |
|
|
103 |
|
(defmethod make-instance ((class (eql (find-class 'make-instance-class-03))) |
104 |
|
&rest initargs |
105 |
|
&key (x nil x-p) (y nil y-p) (z nil z-p) |
106 |
|
&allow-other-keys) |
107 |
|
(declare (ignore initargs)) |
108 |
|
(let ((obj (allocate-instance (find-class 'make-instance-class-03)))) |
109 |
|
(when x-p (setf (slot-value obj 'a) x)) |
110 |
|
(when y-p (setf (slot-value obj 'b) y)) |
111 |
|
(when z-p (setf (slot-value obj 'c) z)) |
112 |
|
obj)) |
113 |
|
|
114 |
|
(deftest make-instance.7 |
115 |
|
(let ((obj (make-instance 'make-instance-class-03))) |
116 |
|
(values |
117 |
|
(eqt (class-of obj) |
118 |
|
(find-class 'make-instance-class-03)) |
119 |
|
(map-slot-boundp* obj '(a b c)))) |
120 |
|
t (nil nil nil)) |
121 |
|
|
122 |
|
(deftest make-instance.8 |
123 |
|
(let* ((class (find-class 'make-instance-class-03)) |
124 |
|
(obj (make-instance class :b 10))) |
125 |
|
(values |
126 |
|
(eqt (class-of obj) class) |
127 |
|
(map-slot-boundp* obj '(a b c)))) |
128 |
|
t (nil nil nil)) |
129 |
|
|
130 |
|
(deftest make-instance.9 |
131 |
|
(let* ((class (find-class 'make-instance-class-03)) |
132 |
|
(obj (make-instance class :x 'g :z 'i :y 'k :foo t :x 'bad))) |
133 |
|
(values |
134 |
|
(eqt (class-of obj) class) |
135 |
|
(map-slot-boundp* obj '(a b c)) |
136 |
|
(map-slot-value obj '(a b c)))) |
137 |
|
t (t t t) (g k i)) |
138 |
|
|
139 |
|
;;; After method combination |
140 |
|
|
141 |
|
(defparameter *make-instance-class-04-var* 0) |
142 |
|
|
143 |
|
(defclass make-instance-class-04 () |
144 |
|
((a :initform *make-instance-class-04-var*))) |
145 |
|
|
146 |
|
(defmethod make-instance :after |
147 |
|
((class (eql (find-class 'make-instance-class-04))) |
148 |
|
&rest initargs &key &allow-other-keys) |
149 |
|
(declare (ignore initargs)) |
150 |
|
(incf *make-instance-class-04-var* 10)) |
151 |
|
|
152 |
|
(deftest make-instance.10 |
153 |
|
(let* ((*make-instance-class-04-var* 0) |
154 |
|
(obj (make-instance 'make-instance-class-04))) |
155 |
|
(values |
156 |
|
(slot-value obj 'a) |
157 |
|
*make-instance-class-04-var*)) |
158 |
|
0 10) |
159 |
|
|
160 |
|
;;; Around method combination |
161 |
|
|
162 |
|
(defclass make-instance-class-05 () |
163 |
|
((a :initarg :a) (b :initarg :b :initform 'foo) c)) |
164 |
|
|
165 |
|
(defmethod make-instance :around |
166 |
|
((class (eql (find-class 'make-instance-class-05))) |
167 |
|
&rest initargs &key &allow-other-keys) |
168 |
|
(declare (ignore initargs)) |
169 |
|
(let ((obj (call-next-method))) |
170 |
|
(setf (slot-value obj 'c) 'bar) |
171 |
|
obj)) |
172 |
|
|
173 |
|
(deftest make-instance.11 |
174 |
|
(let ((obj (make-instance 'make-instance-class-05))) |
175 |
|
(values |
176 |
|
(map-slot-boundp* obj '(a b c)) |
177 |
|
(map-slot-value obj '(b c)))) |
178 |
|
(nil t t) |
179 |
|
(foo bar)) |
180 |
|
|
181 |
;;; Order of argument evaluation |
;;; Order of argument evaluation |
182 |
|
|
183 |
(deftest make-instance.order.1 |
(deftest make-instance.order.1 |