1 |
|
;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*- |
2 |
|
;;; |
3 |
|
;;; ************************************************************************* |
4 |
|
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. |
5 |
|
;;; All rights reserved. |
6 |
|
;;; |
7 |
|
;;; Use and copying of this software and preparation of derivative works |
8 |
|
;;; based upon this software are permitted. Any distribution of this |
9 |
|
;;; software or derivative works must comply with all applicable United |
10 |
|
;;; States export control laws. |
11 |
|
;;; |
12 |
|
;;; This software is made available AS IS, and Xerox Corporation makes no |
13 |
|
;;; warranty about the software, its performance or its conformity to any |
14 |
|
;;; specification. |
15 |
|
;;; |
16 |
|
;;; Any person obtaining a copy of this software is requested to send their |
17 |
|
;;; name and post office or electronic mail address to: |
18 |
|
;;; CommonLoops Coordinator |
19 |
|
;;; Xerox PARC |
20 |
|
;;; 3333 Coyote Hill Rd. |
21 |
|
;;; Palo Alto, CA 94304 |
22 |
|
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) |
23 |
|
;;; |
24 |
|
;;; Suggestions, comments and requests for improvements are also welcome. |
25 |
|
;;; ************************************************************************* |
26 |
|
;;; |
27 |
|
|
28 |
|
(in-package :pcl) |
29 |
|
|
30 |
|
(defmethod slot-accessor-function ((slotd effective-slot-definition) type) |
31 |
|
(ecase type |
32 |
|
(reader (slot-definition-reader-function slotd)) |
33 |
|
(writer (slot-definition-writer-function slotd)) |
34 |
|
(boundp (slot-definition-boundp-function slotd)))) |
35 |
|
|
36 |
|
(defmethod (setf slot-accessor-function) (function |
37 |
|
(slotd effective-slot-definition) type) |
38 |
|
(ecase type |
39 |
|
(reader (setf (slot-definition-reader-function slotd) function)) |
40 |
|
(writer (setf (slot-definition-writer-function slotd) function)) |
41 |
|
(boundp (setf (slot-definition-boundp-function slotd) function)))) |
42 |
|
|
43 |
|
(defconstant *slotd-reader-function-std-p* 1) |
44 |
|
(defconstant *slotd-writer-function-std-p* 2) |
45 |
|
(defconstant *slotd-boundp-function-std-p* 4) |
46 |
|
(defconstant *slotd-all-function-std-p* 7) |
47 |
|
|
48 |
|
(defmethod slot-accessor-std-p ((slotd effective-slot-definition) type) |
49 |
|
(let ((flags (slot-value slotd 'accessor-flags))) |
50 |
|
(declare (type fixnum flags)) |
51 |
|
(if (eq type 'all) |
52 |
|
(eql *slotd-all-function-std-p* flags) |
53 |
|
(let ((mask (ecase type |
54 |
|
(reader *slotd-reader-function-std-p*) |
55 |
|
(writer *slotd-writer-function-std-p*) |
56 |
|
(boundp *slotd-boundp-function-std-p*)))) |
57 |
|
(declare (type fixnum mask)) |
58 |
|
(not (zerop (the fixnum (logand mask flags)))))))) |
59 |
|
|
60 |
|
(defmethod (setf slot-accessor-std-p) (value (slotd effective-slot-definition) type) |
61 |
|
(let ((mask (ecase type |
62 |
|
(reader *slotd-reader-function-std-p*) |
63 |
|
(writer *slotd-writer-function-std-p*) |
64 |
|
(boundp *slotd-boundp-function-std-p*))) |
65 |
|
(flags (slot-value slotd 'accessor-flags))) |
66 |
|
(declare (type fixnum mask flags)) |
67 |
|
(setf (slot-value slotd 'accessor-flags) |
68 |
|
(if value |
69 |
|
(the fixnum (logior mask flags)) |
70 |
|
(the fixnum (logand (the fixnum (lognot mask)) flags))))) |
71 |
|
value) |
72 |
|
|
73 |
|
(defmethod initialize-internal-slot-functions ((slotd effective-slot-definition)) |
74 |
|
(let* ((name (slot-value slotd 'name)) |
75 |
|
(class (slot-value slotd 'class))) |
76 |
|
(let ((table (or (gethash name *name->class->slotd-table*) |
77 |
|
(setf (gethash name *name->class->slotd-table*) |
78 |
|
(make-hash-table :test 'eq :size 5))))) |
79 |
|
(setf (gethash class table) slotd)) |
80 |
|
(dolist (type '(reader writer boundp)) |
81 |
|
(let* ((gf-name (ecase type |
82 |
|
(reader 'slot-value-using-class) |
83 |
|
(writer '(setf slot-value-using-class)) |
84 |
|
(boundp 'slot-boundp-using-class))) |
85 |
|
(gf (gdefinition gf-name))) |
86 |
|
(compute-slot-accessor-info slotd type gf))) |
87 |
|
(initialize-internal-slot-gfs name))) |
88 |
|
|
89 |
|
(defmethod compute-slot-accessor-info ((slotd effective-slot-definition) type gf) |
90 |
|
(let* ((name (slot-value slotd 'name)) |
91 |
|
(class (slot-value slotd 'class)) |
92 |
|
(old-slotd (find-slot-definition class name)) |
93 |
|
(old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all)))) |
94 |
|
(multiple-value-bind (function std-p) |
95 |
|
(if (eq *boot-state* 'complete) |
96 |
|
(get-accessor-method-function gf type class slotd) |
97 |
|
(get-optimized-std-accessor-method-function class slotd type)) |
98 |
|
#+kcl (si:turbo-closure function) |
99 |
|
(setf (slot-accessor-std-p slotd type) std-p) |
100 |
|
(setf (slot-accessor-function slotd type) function)) |
101 |
|
(when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all)))) |
102 |
|
(push (cons class name) *pv-table-cache-update-info*)))) |
103 |
|
|
104 |
|
(defmethod slot-definition-allocation ((slotd structure-slot-definition)) |
105 |
|
:instance) |
106 |
|
|
107 |
|
|
108 |
|
|
109 |
|
(defmethod shared-initialize :after ((object documentation-mixin) |
110 |
|
slot-names |
111 |
|
&key (documentation nil documentation-p)) |
112 |
|
(declare (ignore slot-names)) |
113 |
|
(when documentation-p |
114 |
|
(setf (plist-value object 'documentation) documentation))) |
115 |
|
|
116 |
|
(defmethod documentation (object &optional doc-type) |
117 |
|
(lisp:documentation object doc-type)) |
118 |
|
|
119 |
|
(defmethod (setf documentation) (new-value object &optional doc-type) |
120 |
|
(declare (ignore new-value doc-type)) |
121 |
|
(error "Can't change the documentation of ~S." object)) |
122 |
|
|
123 |
|
|
124 |
|
(defmethod documentation ((object documentation-mixin) &optional doc-type) |
125 |
|
(declare (ignore doc-type)) |
126 |
|
(plist-value object 'documentation)) |
127 |
|
|
128 |
|
(defmethod (setf documentation) (new-value (object documentation-mixin) &optional doc-type) |
129 |
|
(declare (ignore doc-type)) |
130 |
|
(setf (plist-value object 'documentation) new-value)) |
131 |
|
|
132 |
|
|
133 |
|
(defmethod documentation ((slotd standard-slot-definition) &optional doc-type) |
134 |
|
(declare (ignore doc-type)) |
135 |
|
(slot-value slotd 'documentation)) |
136 |
|
|
137 |
|
(defmethod (setf documentation) (new-value (slotd standard-slot-definition) &optional doc-type) |
138 |
|
(declare (ignore doc-type)) |
139 |
|
(setf (slot-value slotd 'documentation) new-value)) |
140 |
|
|
141 |
|
|
142 |
|
;;; |
143 |
|
;;; Various class accessors that are a little more complicated than can be |
144 |
|
;;; done with automatically generated reader methods. |
145 |
|
;;; |
146 |
|
(defmethod class-finalized-p ((class pcl-class)) |
147 |
|
(with-slots (wrapper) class |
148 |
|
(not (null wrapper)))) |
149 |
|
|
150 |
|
(defmethod class-prototype ((class std-class)) |
151 |
|
(with-slots (prototype) class |
152 |
|
(or prototype (setq prototype (allocate-instance class))))) |
153 |
|
|
154 |
|
(defmethod class-prototype ((class structure-class)) |
155 |
|
(with-slots (prototype wrapper defstruct-constructor) class |
156 |
|
(or prototype |
157 |
|
(setq prototype |
158 |
|
(if #-new-kcl-wrapper defstruct-constructor #+new-kcl-wrapper nil |
159 |
|
(allocate-instance class) |
160 |
|
(allocate-standard-instance wrapper)))))) |
161 |
|
|
162 |
|
(defmethod class-direct-default-initargs ((class slot-class)) |
163 |
|
(plist-value class 'direct-default-initargs)) |
164 |
|
|
165 |
|
(defmethod class-default-initargs ((class slot-class)) |
166 |
|
(plist-value class 'default-initargs)) |
167 |
|
|
168 |
|
(defmethod class-constructors ((class slot-class)) |
169 |
|
(plist-value class 'constructors)) |
170 |
|
|
171 |
|
(defmethod class-slot-cells ((class std-class)) |
172 |
|
(plist-value class 'class-slot-cells)) |
173 |
|
|
174 |
|
|
175 |
|
;;; |
176 |
|
;;; Class accessors that are even a little bit more complicated than those |
177 |
|
;;; above. These have a protocol for updating them, we must implement that |
178 |
|
;;; protocol. |
179 |
|
;;; |
180 |
|
|
181 |
|
;;; |
182 |
|
;;; Maintaining the direct subclasses backpointers. The update methods are |
183 |
|
;;; here, the values are read by an automatically generated reader method. |
184 |
|
;;; |
185 |
|
(defmethod add-direct-subclass ((class class) (subclass class)) |
186 |
|
(with-slots (direct-subclasses) class |
187 |
|
(pushnew subclass direct-subclasses) |
188 |
|
subclass)) |
189 |
|
|
190 |
|
(defmethod remove-direct-subclass ((class class) (subclass class)) |
191 |
|
(with-slots (direct-subclasses) class |
192 |
|
(setq direct-subclasses (remove subclass direct-subclasses)) |
193 |
|
subclass)) |
194 |
|
|
195 |
|
;;; |
196 |
|
;;; Maintaining the direct-methods and direct-generic-functions backpointers. |
197 |
|
;;; |
198 |
|
;;; There are four generic functions involved, each has one method for the |
199 |
|
;;; class case and another method for the damned EQL specializers. All of |
200 |
|
;;; these are specified methods and appear in their specified place in the |
201 |
|
;;; class graph. |
202 |
|
;;; |
203 |
|
;;; ADD-DIRECT-METHOD |
204 |
|
;;; REMOVE-DIRECT-METHOD |
205 |
|
;;; SPECIALIZER-DIRECT-METHODS |
206 |
|
;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS |
207 |
|
;;; |
208 |
|
;;; In each case, we maintain one value which is a cons. The car is the list |
209 |
|
;;; methods. The cdr is a list of the generic functions. The cdr is always |
210 |
|
;;; computed lazily. |
211 |
|
;;; |
212 |
|
|
213 |
|
(defmethod add-direct-method ((specializer class) (method method)) |
214 |
|
(with-slots (direct-methods) specializer |
215 |
|
(setf (car direct-methods) (adjoin method (car direct-methods)) ;PUSH |
216 |
|
(cdr direct-methods) ())) |
217 |
|
method) |
218 |
|
|
219 |
|
(defmethod remove-direct-method ((specializer class) (method method)) |
220 |
|
(with-slots (direct-methods) specializer |
221 |
|
(setf (car direct-methods) (remove method (car direct-methods)) |
222 |
|
(cdr direct-methods) ())) |
223 |
|
method) |
224 |
|
|
225 |
|
(defmethod specializer-direct-methods ((specializer class)) |
226 |
|
(with-slots (direct-methods) specializer |
227 |
|
(car direct-methods))) |
228 |
|
|
229 |
|
(defmethod specializer-direct-generic-functions ((specializer class)) |
230 |
|
(with-slots (direct-methods) specializer |
231 |
|
(or (cdr direct-methods) |
232 |
|
(setf (cdr direct-methods) |
233 |
|
(gathering1 (collecting-once) |
234 |
|
(dolist (m (car direct-methods)) |
235 |
|
(gather1 (method-generic-function m)))))))) |
236 |
|
|
237 |
|
|
238 |
|
|
239 |
|
;;; |
240 |
|
;;; This hash table is used to store the direct methods and direct generic |
241 |
|
;;; functions of EQL specializers. Each value in the table is the cons. |
242 |
|
;;; |
243 |
|
(defvar *eql-specializer-methods* (make-hash-table :test #'eql)) |
244 |
|
(defvar *class-eq-specializer-methods* (make-hash-table :test #'eq)) |
245 |
|
|
246 |
|
(defmethod specializer-method-table ((specializer eql-specializer)) |
247 |
|
*eql-specializer-methods*) |
248 |
|
|
249 |
|
(defmethod specializer-method-table ((specializer class-eq-specializer)) |
250 |
|
*class-eq-specializer-methods*) |
251 |
|
|
252 |
|
(defmethod add-direct-method ((specializer specializer-with-object) (method method)) |
253 |
|
(let* ((object (specializer-object specializer)) |
254 |
|
(table (specializer-method-table specializer)) |
255 |
|
(entry (gethash object table))) |
256 |
|
(unless entry |
257 |
|
(setq entry |
258 |
|
(setf (gethash object table) |
259 |
|
(cons nil nil)))) |
260 |
|
(setf (car entry) (adjoin method (car entry)) |
261 |
|
(cdr entry) ()) |
262 |
|
method)) |
263 |
|
|
264 |
|
(defmethod remove-direct-method ((specializer specializer-with-object) (method method)) |
265 |
|
(let* ((object (specializer-object specializer)) |
266 |
|
(entry (gethash object (specializer-method-table specializer)))) |
267 |
|
(when entry |
268 |
|
(setf (car entry) (remove method (car entry)) |
269 |
|
(cdr entry) ())) |
270 |
|
method)) |
271 |
|
|
272 |
|
(defmethod specializer-direct-methods ((specializer specializer-with-object)) |
273 |
|
(car (gethash (specializer-object specializer) |
274 |
|
(specializer-method-table specializer)))) |
275 |
|
|
276 |
|
(defmethod specializer-direct-generic-functions ((specializer specializer-with-object)) |
277 |
|
(let* ((object (specializer-object specializer)) |
278 |
|
(entry (gethash object (specializer-method-table specializer)))) |
279 |
|
(when entry |
280 |
|
(or (cdr entry) |
281 |
|
(setf (cdr entry) |
282 |
|
(gathering1 (collecting-once) |
283 |
|
(dolist (m (car entry)) |
284 |
|
(gather1 (method-generic-function m))))))))) |
285 |
|
|
286 |
|
(defun map-specializers (function) |
287 |
|
(declare (type function function)) |
288 |
|
(map-all-classes #'(lambda (class) |
289 |
|
(funcall function (class-eq-specializer class)) |
290 |
|
(funcall function class))) |
291 |
|
(maphash #'(lambda (object methods) |
292 |
|
(declare (ignore methods)) |
293 |
|
(intern-eql-specializer object)) |
294 |
|
*eql-specializer-methods*) |
295 |
|
(maphash #'(lambda (object specl) |
296 |
|
(declare (ignore object)) |
297 |
|
(funcall function specl)) |
298 |
|
*eql-specializer-table*) |
299 |
|
nil) |
300 |
|
|
301 |
|
(defun map-all-generic-functions (function) |
302 |
|
(declare (type function function)) |
303 |
|
(let ((all-generic-functions (make-hash-table :test 'eq))) |
304 |
|
(map-specializers #'(lambda (specl) |
305 |
|
(dolist (gf (specializer-direct-generic-functions specl)) |
306 |
|
(unless (gethash gf all-generic-functions) |
307 |
|
(setf (gethash gf all-generic-functions) t) |
308 |
|
(funcall function gf)))))) |
309 |
|
nil) |
310 |
|
|
311 |
|
(defmethod shared-initialize :after ((specl class-eq-specializer) slot-names &key) |
312 |
|
(declare (ignore slot-names)) |
313 |
|
(setf (slot-value specl 'type) `(class-eq ,(specializer-class specl)))) |
314 |
|
|
315 |
|
(defmethod shared-initialize :after ((specl eql-specializer) slot-names &key) |
316 |
|
(declare (ignore slot-names)) |
317 |
|
(setf (slot-value specl 'type) `(eql ,(specializer-object specl)))) |
318 |
|
|
319 |
|
|
320 |
|
|
321 |
|
(defun real-load-defclass (name metaclass-name supers slots other accessors) |
322 |
|
(do-standard-defsetfs-for-defclass accessors) ;*** |
323 |
|
(let ((res (apply #'ensure-class name :metaclass metaclass-name |
324 |
|
:direct-superclasses supers |
325 |
|
:direct-slots slots |
326 |
|
:definition-source `((defclass ,name) |
327 |
|
,(load-truename)) |
328 |
|
other))) |
329 |
|
#+cmu17 (kernel:layout-class (class-wrapper res)) |
330 |
|
#-cmu17 res)) |
331 |
|
|
332 |
|
(setf (gdefinition 'load-defclass) #'real-load-defclass) |
333 |
|
|
334 |
|
(defun ensure-class (name &rest all) |
335 |
|
(apply #'ensure-class-using-class name (find-class name nil) all)) |
336 |
|
|
337 |
|
(defmethod ensure-class-using-class (name (class null) &rest args &key) |
338 |
|
(multiple-value-bind (meta initargs) |
339 |
|
(ensure-class-values class args) |
340 |
|
(inform-type-system-about-class (class-prototype meta) name);*** |
341 |
|
(setf class (apply #'make-instance meta :name name initargs) |
342 |
|
(find-class name) class) |
343 |
|
(inform-type-system-about-class class name) ;*** |
344 |
|
class)) |
345 |
|
|
346 |
|
(defmethod ensure-class-using-class (name (class pcl-class) &rest args &key) |
347 |
|
(multiple-value-bind (meta initargs) |
348 |
|
(ensure-class-values class args) |
349 |
|
(unless (eq (class-of class) meta) (change-class class meta)) |
350 |
|
(apply #'reinitialize-instance class initargs) |
351 |
|
(setf (find-class name) class) |
352 |
|
(inform-type-system-about-class class name) ;*** |
353 |
|
class)) |
354 |
|
|
355 |
|
(defmethod class-predicate-name ((class t)) |
356 |
|
'function-returning-nil) |
357 |
|
|
358 |
|
(defun ensure-class-values (class args) |
359 |
|
(let* ((initargs (copy-list args)) |
360 |
|
(unsupplied (list 1)) |
361 |
|
(supplied-meta (getf initargs :metaclass unsupplied)) |
362 |
|
(supplied-supers (getf initargs :direct-superclasses unsupplied)) |
363 |
|
(supplied-slots (getf initargs :direct-slots unsupplied)) |
364 |
|
(meta |
365 |
|
(cond ((neq supplied-meta unsupplied) |
366 |
|
(find-class supplied-meta)) |
367 |
|
((or (null class) |
368 |
|
(forward-referenced-class-p class)) |
369 |
|
*the-class-standard-class*) |
370 |
|
(t |
371 |
|
(class-of class))))) |
372 |
|
(flet ((fix-super (s) |
373 |
|
(cond ((classp s) s) |
374 |
|
((not (legal-class-name-p s)) |
375 |
|
(error "~S is not a class or a legal class name." s)) |
376 |
|
(t |
377 |
|
(or (find-class s nil) |
378 |
|
(setf (find-class s) |
379 |
|
(make-instance 'forward-referenced-class |
380 |
|
:name s))))))) |
381 |
|
;; |
382 |
|
;; CLHS: signal PROGRAM-ERROR, if |
383 |
|
;; (a) there are any duplicate slot names |
384 |
|
;; (b) any of the slot options :ALLOCATION, :INITFORM, :TYPE, or |
385 |
|
;; :DOCUMENTATION appears more than one in a single slot description. |
386 |
|
(loop for (slot . more) on (getf initargs :direct-slots) |
387 |
|
for slot-name = (getf slot :name) |
388 |
|
if (some (lambda (s) (eq slot-name (getf s :name))) more) do |
389 |
|
(specific-error :invalid-form |
390 |
|
"More than one direct slot with name ~S." |
391 |
|
slot-name) |
392 |
|
else do |
393 |
|
(loop for (option value . more) on slot by #'cddr |
394 |
|
when (and (member option '(:allocation :type :initform |
395 |
|
:documentation)) |
396 |
|
(not (eq unsupplied |
397 |
|
(getf more option unsupplied)))) do |
398 |
|
(specific-error :invalid-form |
399 |
|
"Duplicate slot option ~S for slot ~S." |
400 |
|
option slot-name))) |
401 |
|
;; |
402 |
|
;; CLHS: signal PROGRAM-ERROR, if an initialization argument name |
403 |
|
;; appears more than once in :DEFAULT-INITARGS class option. |
404 |
|
(loop for (initarg . more) on (getf initargs :direct-default-initargs) |
405 |
|
for name = (car initarg) |
406 |
|
when (some (lambda (a) (eq (car a) name)) more) do |
407 |
|
(specific-error :invalid-form |
408 |
|
"Duplicate initialization argument ~ |
409 |
|
name ~S in :default-initargs of class ~A." |
410 |
|
name class)) |
411 |
|
;; |
412 |
|
(loop (unless (remf initargs :metaclass) (return))) |
413 |
|
(loop (unless (remf initargs :direct-superclasses) (return))) |
414 |
|
(loop (unless (remf initargs :direct-slots) (return))) |
415 |
|
(values meta |
416 |
|
(list* :direct-superclasses |
417 |
|
(and (neq supplied-supers unsupplied) |
418 |
|
(mapcar #'fix-super supplied-supers)) |
419 |
|
:direct-slots |
420 |
|
(and (neq supplied-slots unsupplied) supplied-slots) |
421 |
|
initargs))))) |
422 |
|
|
423 |
|
|
424 |
|
;;; |
425 |
|
;;; |
426 |
|
;;; |
427 |
|
#|| ; since it doesn't do anything |
428 |
|
(defmethod shared-initialize :before ((class std-class) |
429 |
|
slot-names |
430 |
|
&key direct-superclasses) |
431 |
|
(declare (ignore slot-names)) |
432 |
|
;; *** error checking |
433 |
|
) |
434 |
|
||# |
435 |
|
|
436 |
|
(defmethod shared-initialize :after |
437 |
|
((class std-class) |
438 |
|
slot-names |
439 |
|
&key (direct-superclasses nil direct-superclasses-p) |
440 |
|
(direct-slots nil direct-slots-p) |
441 |
|
(direct-default-initargs nil direct-default-initargs-p) |
442 |
|
(predicate-name nil predicate-name-p)) |
443 |
|
(declare (ignore slot-names)) |
444 |
|
(if direct-superclasses-p |
445 |
|
(progn |
446 |
|
(setq direct-superclasses (or direct-superclasses |
447 |
|
(list *the-class-standard-object*))) |
448 |
|
(dolist (superclass direct-superclasses) |
449 |
|
(unless (validate-superclass class superclass) |
450 |
|
(error "The class ~S was specified as a~%super-class of the class ~S;~%~ |
451 |
|
but the meta-classes ~S and~%~S are incompatible.~% |
452 |
|
Define a method for ~S to avoid this error." |
453 |
|
superclass class (class-of superclass) (class-of class) |
454 |
|
'validate-superclass))) |
455 |
|
(setf (slot-value class 'direct-superclasses) direct-superclasses)) |
456 |
|
(setq direct-superclasses (slot-value class 'direct-superclasses))) |
457 |
|
(setq direct-slots |
458 |
|
(if direct-slots-p |
459 |
|
(setf (slot-value class 'direct-slots) |
460 |
|
(mapcar #'(lambda (pl) (make-direct-slotd class pl)) direct-slots)) |
461 |
|
(slot-value class 'direct-slots))) |
462 |
|
(if direct-default-initargs-p |
463 |
|
(setf (plist-value class 'direct-default-initargs) direct-default-initargs) |
464 |
|
(setq direct-default-initargs (plist-value class 'direct-default-initargs))) |
465 |
|
(setf (plist-value class 'class-slot-cells) |
466 |
|
(gathering1 (collecting) |
467 |
|
(dolist (dslotd direct-slots) |
468 |
|
(when (eq (slot-definition-allocation dslotd) class) |
469 |
|
(let ((initfunction (slot-definition-initfunction dslotd))) |
470 |
|
(gather1 (cons (slot-definition-name dslotd) |
471 |
|
(if initfunction |
472 |
|
(funcall initfunction) |
473 |
|
*slot-unbound*)))))))) |
474 |
|
(setq predicate-name (if predicate-name-p |
475 |
|
(setf (slot-value class 'predicate-name) |
476 |
|
(car predicate-name)) |
477 |
|
(or (slot-value class 'predicate-name) |
478 |
|
(setf (slot-value class 'predicate-name) |
479 |
|
(make-class-predicate-name (class-name class)))))) |
480 |
|
(add-direct-subclasses class direct-superclasses) |
481 |
|
(update-class class nil) |
482 |
|
(make-class-predicate class predicate-name) |
483 |
|
(add-slot-accessors class direct-slots)) |
484 |
|
|
485 |
|
(defmethod shared-initialize :before ((class class) slot-names &key name) |
486 |
|
(declare (ignore slot-names name)) |
487 |
|
(setf (slot-value class 'type) `(class ,class)) |
488 |
|
(setf (slot-value class 'class-eq-specializer) |
489 |
|
(make-instance 'class-eq-specializer :class class))) |
490 |
|
|
491 |
|
(defmethod reinitialize-instance :before ((class slot-class) &key) |
492 |
|
(remove-direct-subclasses class (class-direct-superclasses class)) |
493 |
|
(remove-slot-accessors class (class-direct-slots class))) |
494 |
|
|
495 |
|
(defmethod reinitialize-instance :after ((class slot-class) |
496 |
|
&rest initargs |
497 |
|
&key) |
498 |
|
(map-dependents class |
499 |
|
#'(lambda (dependent) |
500 |
|
(apply #'update-dependent class dependent initargs)))) |
501 |
|
|
502 |
|
(defmethod shared-initialize :after |
503 |
|
((class structure-class) |
504 |
|
slot-names |
505 |
|
&key (direct-superclasses nil direct-superclasses-p) |
506 |
|
(direct-slots nil direct-slots-p) |
507 |
|
direct-default-initargs |
508 |
|
(predicate-name nil predicate-name-p)) |
509 |
|
(declare (ignore slot-names direct-default-initargs)) |
510 |
|
(if direct-superclasses-p |
511 |
|
(setf (slot-value class 'direct-superclasses) |
512 |
|
(or direct-superclasses |
513 |
|
(setq direct-superclasses |
514 |
|
(and (not (eq (class-name class) 'structure-object)) |
515 |
|
(list *the-class-structure-object*))))) |
516 |
|
(setq direct-superclasses (slot-value class 'direct-superclasses))) |
517 |
|
(let* ((name (class-name class)) |
518 |
|
(from-defclass-p (slot-value class 'from-defclass-p)) |
519 |
|
(defstruct-p (or from-defclass-p (not (structure-type-p name))))) |
520 |
|
(if direct-slots-p |
521 |
|
(setf (slot-value class 'direct-slots) |
522 |
|
(setq direct-slots |
523 |
|
(mapcar #'(lambda (pl) |
524 |
|
(when defstruct-p |
525 |
|
(let* ((slot-name (getf pl :name)) |
526 |
|
(acc-name (format nil "~s structure class ~a" |
527 |
|
name slot-name)) |
528 |
|
(accessor (intern acc-name))) |
529 |
|
(setq pl (list* :defstruct-accessor-symbol accessor |
530 |
|
pl)))) |
531 |
|
(make-direct-slotd class pl)) |
532 |
|
direct-slots))) |
533 |
|
(setq direct-slots (slot-value class 'direct-slots))) |
534 |
|
(when defstruct-p |
535 |
|
(let* ((include (car (slot-value class 'direct-superclasses))) |
536 |
|
(conc-name (intern (format nil "~s structure class " name))) |
537 |
|
(constructor (intern (format nil "~a constructor" conc-name))) |
538 |
|
(defstruct `(defstruct (,name |
539 |
|
,@(when include |
540 |
|
`((:include ,(class-name include)))) |
541 |
|
(:print-function print-std-instance) |
542 |
|
(:predicate nil) |
543 |
|
(:conc-name ,conc-name) |
544 |
|
(:constructor ,constructor ())) |
545 |
|
,@(mapcar #'(lambda (slot) |
546 |
|
`(,(slot-definition-name slot) |
547 |
|
*slot-unbound*)) |
548 |
|
direct-slots))) |
549 |
|
(reader-names (mapcar #'(lambda (slotd) |
550 |
|
(intern (format nil "~A~A reader" conc-name |
551 |
|
(slot-definition-name slotd)))) |
552 |
|
direct-slots)) |
553 |
|
(writer-names (mapcar #'(lambda (slotd) |
554 |
|
(intern (format nil "~A~A writer" conc-name |
555 |
|
(slot-definition-name slotd)))) |
556 |
|
direct-slots)) |
557 |
|
(readers-init |
558 |
|
(mapcar #'(lambda (slotd reader-name) |
559 |
|
(let ((accessor |
560 |
|
(slot-definition-defstruct-accessor-symbol slotd))) |
561 |
|
`(defun ,reader-name (obj) |
562 |
|
(declare (type ,name obj)) |
563 |
|
(,accessor obj)))) |
564 |
|
direct-slots reader-names)) |
565 |
|
(writers-init |
566 |
|
(mapcar #'(lambda (slotd writer-name) |
567 |
|
(let ((accessor |
568 |
|
(slot-definition-defstruct-accessor-symbol slotd))) |
569 |
|
`(defun ,writer-name (nv obj) |
570 |
|
(declare (type ,name obj)) |
571 |
|
(setf (,accessor obj) nv)))) |
572 |
|
direct-slots writer-names)) |
573 |
|
(defstruct-form |
574 |
|
`(progn |
575 |
|
,defstruct |
576 |
|
,@readers-init ,@writers-init |
577 |
|
(declare-structure ',name nil nil)))) |
578 |
|
(unless (structure-type-p name) (eval defstruct-form)) |
579 |
|
(mapc #'(lambda (dslotd reader-name writer-name) |
580 |
|
(let* ((reader (gdefinition reader-name)) |
581 |
|
(writer (when (gboundp writer-name) |
582 |
|
(gdefinition writer-name)))) |
583 |
|
(setf (slot-value dslotd 'internal-reader-function) reader) |
584 |
|
(setf (slot-value dslotd 'internal-writer-function) writer))) |
585 |
|
direct-slots reader-names writer-names) |
586 |
|
(setf (slot-value class 'defstruct-form) defstruct-form) |
587 |
|
(setf (slot-value class 'defstruct-constructor) constructor)))) |
588 |
|
(add-direct-subclasses class direct-superclasses) |
589 |
|
(setf (slot-value class 'class-precedence-list) |
590 |
|
(compute-class-precedence-list class)) |
591 |
|
(setf (slot-value class 'slots) (compute-slots class)) |
592 |
|
#-(or cmu17 new-kcl-wrapper) |
593 |
|
(unless (slot-value class 'wrapper) |
594 |
|
(setf (slot-value class 'wrapper) (make-wrapper 0 class))) |
595 |
|
#+cmu17 |
596 |
|
(let ((lclass (lisp:find-class (class-name class)))) |
597 |
|
(setf (kernel:class-pcl-class lclass) class) |
598 |
|
(setf (slot-value class 'wrapper) (kernel:class-layout lclass))) |
599 |
|
#+new-kcl-wrapper |
600 |
|
(let ((wrapper (get (class-name class) 'si::s-data))) |
601 |
|
(setf (slot-value class 'wrapper) wrapper) |
602 |
|
(setf (wrapper-class wrapper) class)) |
603 |
|
(update-pv-table-cache-info class) |
604 |
|
(setq predicate-name (if predicate-name-p |
605 |
|
(setf (slot-value class 'predicate-name) |
606 |
|
(car predicate-name)) |
607 |
|
(or (slot-value class 'predicate-name) |
608 |
|
(setf (slot-value class 'predicate-name) |
609 |
|
(make-class-predicate-name (class-name class)))))) |
610 |
|
(make-class-predicate class predicate-name) |
611 |
|
(add-slot-accessors class direct-slots)) |
612 |
|
|
613 |
|
(defmethod direct-slot-definition-class ((class structure-class) initargs) |
614 |
|
(declare (ignore initargs)) |
615 |
|
(find-class 'structure-direct-slot-definition)) |
616 |
|
|
617 |
|
(defmethod finalize-inheritance ((class structure-class)) |
618 |
|
nil) ; always finalized |
619 |
|
|
620 |
|
(defun add-slot-accessors (class dslotds) |
621 |
|
(fix-slot-accessors class dslotds 'add)) |
622 |
|
|
623 |
|
(defun remove-slot-accessors (class dslotds) |
624 |
|
(fix-slot-accessors class dslotds 'remove)) |
625 |
|
|
626 |
|
(defun fix-slot-accessors (class dslotds add/remove) |
627 |
|
(flet ((fix (gfspec name r/w) |
628 |
|
(let ((gf (ensure-generic-function gfspec))) |
629 |
|
(case r/w |
630 |
|
(r (if (eq add/remove 'add) |
631 |
|
(add-reader-method class gf name) |
632 |
|
(remove-reader-method class gf))) |
633 |
|
(w (if (eq add/remove 'add) |
634 |
|
(add-writer-method class gf name) |
635 |
|
(remove-writer-method class gf))))))) |
636 |
|
(dolist (dslotd dslotds) |
637 |
|
(let ((slot-name (slot-definition-name dslotd))) |
638 |
|
(dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r)) |
639 |
|
(dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w)))))) |
640 |
|
|
641 |
|
|
642 |
|
(defun add-direct-subclasses (class new) |
643 |
|
(dolist (n new) |
644 |
|
(unless (memq class (class-direct-subclasses class)) |
645 |
|
(add-direct-subclass n class)))) |
646 |
|
|
647 |
|
(defun remove-direct-subclasses (class new) |
648 |
|
(let ((old (class-direct-superclasses class))) |
649 |
|
(dolist (o (set-difference old new)) |
650 |
|
(remove-direct-subclass o class)))) |
651 |
|
|
652 |
|
|
653 |
|
;;; |
654 |
|
;;; |
655 |
|
;;; |
656 |
|
(defmethod finalize-inheritance ((class std-class)) |
657 |
|
(update-class class t)) |
658 |
|
|
659 |
|
|
660 |
|
(defun class-has-a-forward-referenced-superclass-p (class) |
661 |
|
(or (forward-referenced-class-p class) |
662 |
|
(some #'class-has-a-forward-referenced-superclass-p |
663 |
|
(class-direct-superclasses class)))) |
664 |
|
|
665 |
|
;;; |
666 |
|
;;; Called by :after shared-initialize whenever a class is initialized or |
667 |
|
;;; reinitialized. The class may or may not be finalized. |
668 |
|
;;; |
669 |
|
(defun update-class (class finalizep) |
670 |
|
(when (or finalizep (class-finalized-p class) |
671 |
|
(not (class-has-a-forward-referenced-superclass-p class))) |
672 |
|
(update-cpl class (compute-class-precedence-list class)) |
673 |
|
(update-slots class (compute-slots class)) |
674 |
|
(update-gfs-of-class class) |
675 |
|
(update-inits class (compute-default-initargs class)) |
676 |
|
(update-make-instance-function-table class)) |
677 |
|
(unless finalizep |
678 |
|
(dolist (sub (class-direct-subclasses class)) (update-class sub nil)))) |
679 |
|
|
680 |
|
(defun update-cpl (class cpl) |
681 |
|
(when (class-finalized-p class) |
682 |
|
(unless (equal (class-precedence-list class) cpl) |
683 |
|
(force-cache-flushes class))) |
684 |
|
(setf (slot-value class 'class-precedence-list) cpl) |
685 |
|
(update-class-can-precede-p cpl)) |
686 |
|
|
687 |
|
(defun update-class-can-precede-p (cpl) |
688 |
|
(when cpl |
689 |
|
(let ((first (car cpl))) |
690 |
|
(dolist (c (cdr cpl)) |
691 |
|
(pushnew c (slot-value first 'can-precede-list)))) |
692 |
|
(update-class-can-precede-p (cdr cpl)))) |
693 |
|
|
694 |
|
(defun class-can-precede-p (class1 class2) |
695 |
|
(member class2 (class-can-precede-list class1))) |
696 |
|
|
697 |
|
(defun update-slots (class eslotds) |
698 |
|
(let ((instance-slots ()) |
699 |
|
(class-slots ())) |
700 |
|
(dolist (eslotd eslotds) |
701 |
|
(let ((alloc (slot-definition-allocation eslotd))) |
702 |
|
(cond ((eq alloc :instance) (push eslotd instance-slots)) |
703 |
|
((classp alloc) (push eslotd class-slots))))) |
704 |
|
;; |
705 |
|
;; If there is a change in the shape of the instances then the |
706 |
|
;; old class is now obsolete. |
707 |
|
;; |
708 |
|
(let* ((nlayout (mapcar #'slot-definition-name |
709 |
|
(sort instance-slots #'< :key #'slot-definition-location))) |
710 |
|
(nslots (length nlayout)) |
711 |
|
(nwrapper-class-slots (compute-class-slots class-slots)) |
712 |
|
(owrapper (class-wrapper class)) |
713 |
|
(olayout (and owrapper (wrapper-instance-slots-layout owrapper))) |
714 |
|
(owrapper-class-slots (and owrapper (wrapper-class-slots owrapper))) |
715 |
|
(nwrapper |
716 |
|
(cond ((null owrapper) |
717 |
|
(make-wrapper nslots class)) |
718 |
|
((and (equal nlayout olayout) |
719 |
|
(not |
720 |
|
(iterate ((o (list-elements owrapper-class-slots)) |
721 |
|
(n (list-elements nwrapper-class-slots))) |
722 |
|
(unless (eq (car o) (car n)) (return t))))) |
723 |
|
owrapper) |
724 |
|
(t |
725 |
|
;; |
726 |
|
;; This will initialize the new wrapper to have the same |
727 |
|
;; state as the old wrapper. We will then have to change |
728 |
|
;; that. This may seem like wasted work (it is), but the |
729 |
|
;; spec requires that we call make-instances-obsolete. |
730 |
|
;; |
731 |
|
(make-instances-obsolete class) |
732 |
|
(class-wrapper class))))) |
733 |
|
|
734 |
|
(with-slots (wrapper slots) class |
735 |
|
#+new-kcl-wrapper |
736 |
|
(setf (si::s-data-name nwrapper) (class-name class)) |
737 |
|
#+cmu17 |
738 |
|
(update-lisp-class-layout class nwrapper) |
739 |
|
(setf slots eslotds |
740 |
|
(wrapper-instance-slots-layout nwrapper) nlayout |
741 |
|
(wrapper-class-slots nwrapper) nwrapper-class-slots |
742 |
|
(wrapper-no-of-instance-slots nwrapper) nslots |
743 |
|
wrapper nwrapper)) |
744 |
|
|
745 |
|
(unless (eq owrapper nwrapper) |
746 |
|
(update-pv-table-cache-info class))))) |
747 |
|
|
748 |
|
(defun compute-class-slots (eslotds) |
749 |
|
(gathering1 (collecting) |
750 |
|
(dolist (eslotd eslotds) |
751 |
|
(gather1 |
752 |
|
(assoc (slot-definition-name eslotd) |
753 |
|
(class-slot-cells (slot-definition-allocation eslotd))))))) |
754 |
|
|
755 |
|
(defun compute-layout (cpl instance-eslotds) |
756 |
|
(let* ((names |
757 |
|
(gathering1 (collecting) |
758 |
|
(dolist (eslotd instance-eslotds) |
759 |
|
(when (eq (slot-definition-allocation eslotd) :instance) |
760 |
|
(gather1 (slot-definition-name eslotd)))))) |
761 |
|
(order ())) |
762 |
|
(labels ((rwalk (tail) |
763 |
|
(when tail |
764 |
|
(rwalk (cdr tail)) |
765 |
|
(dolist (ss (class-slots (car tail))) |
766 |
|
(let ((n (slot-definition-name ss))) |
767 |
|
(when (member n names) |
768 |
|
(setq order (cons n order) |
769 |
|
names (remove n names)))))))) |
770 |
|
(rwalk (if (slot-boundp (car cpl) 'slots) |
771 |
|
cpl |
772 |
|
(cdr cpl))) |
773 |
|
(reverse (append names order))))) |
774 |
|
|
775 |
|
(defun update-gfs-of-class (class) |
776 |
|
(when (and (class-finalized-p class) |
777 |
|
(let ((cpl (class-precedence-list class))) |
778 |
|
(or (member *the-class-slot-class* cpl) |
779 |
|
(member *the-class-standard-effective-slot-definition* cpl)))) |
780 |
|
(let ((gf-table (make-hash-table :test 'eq))) |
781 |
|
(labels ((collect-gfs (class) |
782 |
|
(dolist (gf (specializer-direct-generic-functions class)) |
783 |
|
(setf (gethash gf gf-table) t)) |
784 |
|
(mapc #'collect-gfs (class-direct-superclasses class)))) |
785 |
|
(collect-gfs class) |
786 |
|
(maphash #'(lambda (gf ignore) |
787 |
|
(declare (ignore ignore)) |
788 |
|
(update-gf-dfun class gf)) |
789 |
|
gf-table))))) |
790 |
|
|
791 |
|
(defun update-inits (class inits) |
792 |
|
(setf (plist-value class 'default-initargs) inits)) |
793 |
|
|
794 |
|
|
795 |
|
;;; |
796 |
|
;;; |
797 |
|
;;; |
798 |
|
(defmethod compute-default-initargs ((class slot-class)) |
799 |
|
(let ((cpl (class-precedence-list class)) |
800 |
|
(direct (class-direct-default-initargs class))) |
801 |
|
(labels ((walk (tail) |
802 |
|
(if (null tail) |
803 |
|
nil |
804 |
|
(let ((c (pop tail))) |
805 |
|
(append (if (eq c class) |
806 |
|
direct |
807 |
|
(class-direct-default-initargs c)) |
808 |
|
(walk tail)))))) |
809 |
|
(let ((initargs (walk cpl))) |
810 |
|
(delete-duplicates initargs :test #'eq :key #'car :from-end t))))) |
811 |
|
|
812 |
|
|
813 |
|
;;; |
814 |
|
;;; Protocols for constructing direct and effective slot definitions. |
815 |
|
;;; |
816 |
|
;;; |
817 |
|
;;; |
818 |
|
;;; |
819 |
|
(defmethod direct-slot-definition-class ((class std-class) initargs) |
820 |
|
(declare (ignore initargs)) |
821 |
|
(find-class 'standard-direct-slot-definition)) |
822 |
|
|
823 |
|
(defun make-direct-slotd (class initargs) |
824 |
|
(let ((initargs (list* :class class initargs))) |
825 |
|
(apply #'make-instance (direct-slot-definition-class class initargs) initargs))) |
826 |
|
|
827 |
|
;;; |
828 |
|
;;; |
829 |
|
;;; |
830 |
|
(defmethod compute-slots ((class std-class)) |
831 |
|
;; |
832 |
|
;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once |
833 |
|
;; for each different slot name we find in our superclasses. Each |
834 |
|
;; call receives the class and a list of the dslotds with that name. |
835 |
|
;; The list is in most-specific-first order. |
836 |
|
;; |
837 |
|
(let ((name-dslotds-alist ())) |
838 |
|
(dolist (c (class-precedence-list class)) |
839 |
|
(let ((dslotds (class-direct-slots c))) |
840 |
|
(dolist (d dslotds) |
841 |
|
(let* ((name (slot-definition-name d)) |
842 |
|
(entry (assq name name-dslotds-alist))) |
843 |
|
(if entry |
844 |
|
(push d (cdr entry)) |
845 |
|
(push (list name d) name-dslotds-alist)))))) |
846 |
|
(mapcar #'(lambda (direct) |
847 |
|
(compute-effective-slot-definition class |
848 |
|
(nreverse (cdr direct)))) |
849 |
|
name-dslotds-alist))) |
850 |
|
|
851 |
|
(defmethod compute-slots :around ((class std-class)) |
852 |
|
(let ((eslotds (call-next-method)) |
853 |
|
(cpl (class-precedence-list class)) |
854 |
|
(instance-slots ()) |
855 |
|
(class-slots ())) |
856 |
|
(dolist (eslotd eslotds) |
857 |
|
(let ((alloc (slot-definition-allocation eslotd))) |
858 |
|
(cond ((eq alloc :instance) (push eslotd instance-slots)) |
859 |
|
((classp alloc) (push eslotd class-slots))))) |
860 |
|
(let ((nlayout (compute-layout cpl instance-slots))) |
861 |
|
(dolist (eslotd instance-slots) |
862 |
|
(setf (slot-definition-location eslotd) |
863 |
|
(position (slot-definition-name eslotd) nlayout)))) |
864 |
|
(dolist (eslotd class-slots) |
865 |
|
(setf (slot-definition-location eslotd) |
866 |
|
(assoc (slot-definition-name eslotd) |
867 |
|
(class-slot-cells (slot-definition-allocation eslotd))))) |
868 |
|
(mapc #'initialize-internal-slot-functions eslotds) |
869 |
|
eslotds)) |
870 |
|
|
871 |
|
(defmethod compute-slots ((class structure-class)) |
872 |
|
(mapcan #'(lambda (superclass) |
873 |
|
(mapcar #'(lambda (dslotd) |
874 |
|
(compute-effective-slot-definition class |
875 |
|
(list dslotd))) |
876 |
|
(class-direct-slots superclass))) |
877 |
|
(reverse (slot-value class 'class-precedence-list)))) |
878 |
|
|
879 |
|
(defmethod compute-slots :around ((class structure-class)) |
880 |
|
(let ((eslotds (call-next-method))) |
881 |
|
(mapc #'initialize-internal-slot-functions eslotds) |
882 |
|
eslotds)) |
883 |
|
|
884 |
|
(defmethod compute-effective-slot-definition ((class slot-class) dslotds) |
885 |
|
(let* ((initargs (compute-effective-slot-definition-initargs class dslotds)) |
886 |
|
(class (effective-slot-definition-class class initargs))) |
887 |
|
(apply #'make-instance class initargs))) |
888 |
|
|
889 |
|
(defmethod effective-slot-definition-class ((class std-class) initargs) |
890 |
|
(declare (ignore initargs)) |
891 |
|
(find-class 'standard-effective-slot-definition)) |
892 |
|
|
893 |
|
(defmethod effective-slot-definition-class ((class structure-class) initargs) |
894 |
|
(declare (ignore initargs)) |
895 |
|
(find-class 'structure-effective-slot-definition)) |
896 |
|
|
897 |
|
(defmethod compute-effective-slot-definition-initargs |
898 |
|
((class slot-class) direct-slotds) |
899 |
|
(let* ((name nil) |
900 |
|
(initfunction nil) |
901 |
|
(initform nil) |
902 |
|
(initargs nil) |
903 |
|
(allocation nil) |
904 |
|
(type t) |
905 |
|
(namep nil) |
906 |
|
(initp nil) |
907 |
|
(allocp nil)) |
908 |
|
|
909 |
|
(dolist (slotd direct-slotds) |
910 |
|
(when slotd |
911 |
|
(unless namep |
912 |
|
(setq name (slot-definition-name slotd) |
913 |
|
namep t)) |
914 |
|
(unless initp |
915 |
|
(when (slot-definition-initfunction slotd) |
916 |
|
(setq initform (slot-definition-initform slotd) |
917 |
|
initfunction (slot-definition-initfunction slotd) |
918 |
|
initp t))) |
919 |
|
(unless allocp |
920 |
|
(setq allocation (slot-definition-allocation slotd) |
921 |
|
allocp t)) |
922 |
|
(setq initargs (append (slot-definition-initargs slotd) initargs)) |
923 |
|
(let ((slotd-type (slot-definition-type slotd))) |
924 |
|
(setq type (cond ((eq type 't) slotd-type) |
925 |
|
((*subtypep type slotd-type) type) |
926 |
|
(t `(and ,type ,slotd-type))))))) |
927 |
|
(list :name name |
928 |
|
:initform initform |
929 |
|
:initfunction initfunction |
930 |
|
:initargs initargs |
931 |
|
:allocation allocation |
932 |
|
:type type |
933 |
|
:class class))) |
934 |
|
|
935 |
|
(defmethod compute-effective-slot-definition-initargs :around |
936 |
|
((class structure-class) direct-slotds) |
937 |
|
(let ((slotd (car direct-slotds))) |
938 |
|
(list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd) |
939 |
|
:internal-reader-function (slot-definition-internal-reader-function slotd) |
940 |
|
:internal-writer-function (slot-definition-internal-writer-function slotd) |
941 |
|
(call-next-method)))) |
942 |
|
|
943 |
|
;;; |
944 |
|
;;; NOTE: For bootstrapping considerations, these can't use make-instance |
945 |
|
;;; to make the method object. They have to use make-a-method which |
946 |
|
;;; is a specially bootstrapped mechanism for making standard methods. |
947 |
|
;;; |
948 |
|
(defmethod reader-method-class ((class slot-class) direct-slot &rest initargs) |
949 |
|
(declare (ignore direct-slot initargs)) |
950 |
|
(find-class 'standard-reader-method)) |
951 |
|
|
952 |
|
(defmethod add-reader-method ((class slot-class) generic-function slot-name) |
953 |
|
(add-method generic-function |
954 |
|
(make-a-method 'standard-reader-method |
955 |
|
() |
956 |
|
(list (or (class-name class) 'object)) |
957 |
|
(list class) |
958 |
|
(make-reader-method-function class slot-name) |
959 |
|
"automatically generated reader method" |
960 |
|
slot-name))) |
961 |
|
|
962 |
|
(defmethod writer-method-class ((class slot-class) direct-slot &rest initargs) |
963 |
|
(declare (ignore direct-slot initargs)) |
964 |
|
(find-class 'standard-writer-method)) |
965 |
|
|
966 |
|
(defmethod add-writer-method ((class slot-class) generic-function slot-name) |
967 |
|
(add-method generic-function |
968 |
|
(make-a-method 'standard-writer-method |
969 |
|
() |
970 |
|
(list 'new-value (or (class-name class) 'object)) |
971 |
|
(list *the-class-t* class) |
972 |
|
(make-writer-method-function class slot-name) |
973 |
|
"automatically generated writer method" |
974 |
|
slot-name))) |
975 |
|
|
976 |
|
(defmethod add-boundp-method ((class slot-class) generic-function slot-name) |
977 |
|
(add-method generic-function |
978 |
|
(make-a-method 'standard-boundp-method |
979 |
|
() |
980 |
|
(list (or (class-name class) 'object)) |
981 |
|
(list class) |
982 |
|
(make-boundp-method-function class slot-name) |
983 |
|
"automatically generated boundp method" |
984 |
|
slot-name))) |
985 |
|
|
986 |
|
(defmethod remove-reader-method ((class slot-class) generic-function) |
987 |
|
(let ((method (get-method generic-function () (list class) nil))) |
988 |
|
(when method (remove-method generic-function method)))) |
989 |
|
|
990 |
|
(defmethod remove-writer-method ((class slot-class) generic-function) |
991 |
|
(let ((method |
992 |
|
(get-method generic-function () (list *the-class-t* class) nil))) |
993 |
|
(when method (remove-method generic-function method)))) |
994 |
|
|
995 |
|
(defmethod remove-boundp-method ((class slot-class) generic-function) |
996 |
|
(let ((method (get-method generic-function () (list class) nil))) |
997 |
|
(when method (remove-method generic-function method)))) |
998 |
|
|
999 |
|
|
1000 |
|
;;; |
1001 |
|
;;; make-reader-method-function and make-write-method function are NOT part of |
1002 |
|
;;; the standard protocol. They are however useful, PCL makes uses makes use |
1003 |
|
;;; of them internally and documents them for PCL users. |
1004 |
|
;;; |
1005 |
|
;;; *** This needs work to make type testing by the writer functions which |
1006 |
|
;;; *** do type testing faster. The idea would be to have one constructor |
1007 |
|
;;; *** for each possible type test. In order to do this it would be nice |
1008 |
|
;;; *** to have help from inform-type-system-about-class and friends. |
1009 |
|
;;; |
1010 |
|
;;; *** There is a subtle bug here which is going to have to be fixed. |
1011 |
|
;;; *** Namely, the simplistic use of the template has to be fixed. We |
1012 |
|
;;; *** have to give the optimize-slot-value method the user might have |
1013 |
|
;;; *** defined for this metclass a chance to run. |
1014 |
|
;;; |
1015 |
|
(defmethod make-reader-method-function ((class slot-class) slot-name) |
1016 |
|
(make-std-reader-method-function (class-name class) slot-name)) |
1017 |
|
|
1018 |
|
(defmethod make-writer-method-function ((class slot-class) slot-name) |
1019 |
|
(make-std-writer-method-function (class-name class) slot-name)) |
1020 |
|
|
1021 |
|
(defmethod make-boundp-method-function ((class slot-class) slot-name) |
1022 |
|
(make-std-boundp-method-function (class-name class) slot-name)) |
1023 |
|
|
1024 |
|
|
1025 |
|
;;;; inform-type-system-about-class |
1026 |
|
;;;; make-type-predicate |
1027 |
|
;;; |
1028 |
|
;;; These are NOT part of the standard protocol. They are internal mechanism |
1029 |
|
;;; which PCL uses to *try* and tell the type system about class definitions. |
1030 |
|
;;; In a more fully integrated implementation of CLOS, the type system would |
1031 |
|
;;; know about class objects and class names in a more fundamental way and |
1032 |
|
;;; the mechanism used to inform the type system about new classes would be |
1033 |
|
;;; different. |
1034 |
|
;;; |
1035 |
|
(defmethod inform-type-system-about-class ((class std-class) name) |
1036 |
|
(inform-type-system-about-std-class name)) |
1037 |
|
|
1038 |
|
|
1039 |
|
(defmethod compatible-meta-class-change-p (class proto-new-class) |
1040 |
|
(eq (class-of class) (class-of proto-new-class))) |
1041 |
|
|
1042 |
|
(defmethod validate-superclass ((class class) (new-super class)) |
1043 |
|
(or (eq new-super *the-class-t*) |
1044 |
|
(eq (class-of class) (class-of new-super)))) |
1045 |
|
|
1046 |
|
|
1047 |
|
|
1048 |
|
;;; |
1049 |
|
;;; |
1050 |
|
;;; |
1051 |
|
(defun force-cache-flushes (class) |
1052 |
|
(let* ((owrapper (class-wrapper class)) |
1053 |
|
(state (wrapper-state owrapper))) |
1054 |
|
;; |
1055 |
|
;; We only need to do something if the state is still T. If the |
1056 |
|
;; state isn't T, it will be FLUSH or OBSOLETE, and both of those |
1057 |
|
;; will already be doing what we want. In particular, we must be |
1058 |
|
;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE |
1059 |
|
;; means do what FLUSH does and then some. |
1060 |
|
;; |
1061 |
|
(when (eq state 't) |
1062 |
|
(let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) |
1063 |
|
class))) |
1064 |
|
(setf (wrapper-instance-slots-layout nwrapper) |
1065 |
|
(wrapper-instance-slots-layout owrapper)) |
1066 |
|
(setf (wrapper-class-slots nwrapper) |
1067 |
|
(wrapper-class-slots owrapper)) |
1068 |
|
(without-interrupts |
1069 |
|
#+cmu17 |
1070 |
|
(update-lisp-class-layout class nwrapper) |
1071 |
|
(setf (slot-value class 'wrapper) nwrapper) |
1072 |
|
(invalidate-wrapper owrapper ':flush nwrapper)))))) |
1073 |
|
|
1074 |
|
(defun flush-cache-trap (owrapper nwrapper instance) |
1075 |
|
(declare (ignore owrapper)) |
1076 |
|
(set-wrapper instance nwrapper)) |
1077 |
|
|
1078 |
|
|
1079 |
|
|
1080 |
|
;;; |
1081 |
|
;;; make-instances-obsolete can be called by user code. It will cause the |
1082 |
|
;;; next access to the instance (as defined in 88-002R) to trap through the |
1083 |
|
;;; update-instance-for-redefined-class mechanism. |
1084 |
|
;;; |
1085 |
|
(defmethod make-instances-obsolete ((class std-class)) |
1086 |
|
(let* ((owrapper (class-wrapper class)) |
1087 |
|
(nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) |
1088 |
|
class))) |
1089 |
|
(setf (wrapper-instance-slots-layout nwrapper) |
1090 |
|
(wrapper-instance-slots-layout owrapper)) |
1091 |
|
(setf (wrapper-class-slots nwrapper) |
1092 |
|
(wrapper-class-slots owrapper)) |
1093 |
|
(without-interrupts |
1094 |
|
#+cmu17 |
1095 |
|
(update-lisp-class-layout class nwrapper) |
1096 |
|
(setf (slot-value class 'wrapper) nwrapper) |
1097 |
|
(invalidate-wrapper owrapper ':obsolete nwrapper) |
1098 |
|
class))) |
1099 |
|
|
1100 |
|
(defmethod make-instances-obsolete ((class symbol)) |
1101 |
|
(make-instances-obsolete (find-class class))) |
1102 |
|
|
1103 |
|
|
1104 |
|
;;; |
1105 |
|
;;; obsolete-instance-trap is the internal trap that is called when we see |
1106 |
|
;;; an obsolete instance. The times when it is called are: |
1107 |
|
;;; - when the instance is involved in method lookup |
1108 |
|
;;; - when attempting to access a slot of an instance |
1109 |
|
;;; |
1110 |
|
;;; It is not called by class-of, wrapper-of, or any of the low-level instance |
1111 |
|
;;; access macros. |
1112 |
|
;;; |
1113 |
|
;;; Of course these times when it is called are an internal implementation |
1114 |
|
;;; detail of PCL and are not part of the documented description of when the |
1115 |
|
;;; obsolete instance update happens. The documented description is as it |
1116 |
|
;;; appears in 88-002R. |
1117 |
|
;;; |
1118 |
|
;;; This has to return the new wrapper, so it counts on all the methods on |
1119 |
|
;;; obsolete-instance-trap-internal to return the new wrapper. It also does |
1120 |
|
;;; a little internal error checking to make sure that the traps are only |
1121 |
|
;;; happening when they should, and that the trap methods are computing |
1122 |
|
;;; apropriate new wrappers. |
1123 |
|
;;; |
1124 |
|
|
1125 |
|
;;; obsolete-instance-trap might be called on structure instances |
1126 |
|
;;; after a structure is redefined. In most cases, obsolete-instance-trap |
1127 |
|
;;; will not be able to fix the old instance, so it must signal an |
1128 |
|
;;; error. The hard part of this is that the error system and debugger |
1129 |
|
;;; might cause obsolete-instance-trap to be called again, so in that |
1130 |
|
;;; case, we have to return some reasonable wrapper, instead. |
1131 |
|
|
1132 |
|
(defvar *in-obsolete-instance-trap* nil) |
1133 |
|
(defvar *the-wrapper-of-structure-object* |
1134 |
|
(class-wrapper (find-class 'structure-object))) |
1135 |
|
|
1136 |
|
#+cmu17 |
1137 |
|
(define-condition obsolete-structure (error) |
1138 |
|
((datum :reader obsolete-structure-datum :initarg :datum)) |
1139 |
|
(:report |
1140 |
|
(lambda (condition stream) |
1141 |
|
;; Don't try to print the structure, since it probably |
1142 |
|
;; won't work. |
1143 |
|
(format stream "Obsolete structure error in ~S:~@ |
1144 |
|
For a structure of type: ~S" |
1145 |
|
(conditions::condition-function-name condition) |
1146 |
|
(type-of (obsolete-structure-datum condition)))))) |
1147 |
|
|
1148 |
|
(defun obsolete-instance-trap (owrapper nwrapper instance) |
1149 |
|
(if (not #-(or cmu17 new-kcl-wrapper) |
1150 |
|
(or (std-instance-p instance) (fsc-instance-p instance)) |
1151 |
|
#+cmu17 |
1152 |
|
(pcl-instance-p instance) |
1153 |
|
#+new-kcl-wrapper |
1154 |
|
nil) |
1155 |
|
(if *in-obsolete-instance-trap* |
1156 |
|
*the-wrapper-of-structure-object* |
1157 |
|
(let ((*in-obsolete-instance-trap* t)) |
1158 |
|
#-cmu17 |
1159 |
|
(error "The structure ~S is obsolete." instance) |
1160 |
|
#+cmu17 |
1161 |
|
(error 'obsolete-structure :datum instance))) |
1162 |
|
(let* ((class (wrapper-class* nwrapper)) |
1163 |
|
(copy (allocate-instance class)) ;??? allocate-instance ??? |
1164 |
|
(olayout (wrapper-instance-slots-layout owrapper)) |
1165 |
|
(nlayout (wrapper-instance-slots-layout nwrapper)) |
1166 |
|
(oslots (get-slots instance)) |
1167 |
|
(nslots (get-slots copy)) |
1168 |
|
(oclass-slots (wrapper-class-slots owrapper)) |
1169 |
|
(added ()) |
1170 |
|
(discarded ()) |
1171 |
|
(plist ())) |
1172 |
|
;; local --> local transfer |
1173 |
|
;; local --> shared discard |
1174 |
|
;; local --> -- discard |
1175 |
|
;; shared --> local transfer |
1176 |
|
;; shared --> shared discard |
1177 |
|
;; shared --> -- discard |
1178 |
|
;; -- --> local add |
1179 |
|
;; -- --> shared -- |
1180 |
|
;; |
1181 |
|
;; Go through all the old local slots. |
1182 |
|
;; |
1183 |
|
(iterate ((name (list-elements olayout)) |
1184 |
|
(opos (interval :from 0))) |
1185 |
|
(let* ((opos opos) |
1186 |
|
(npos (posq name nlayout))) |
1187 |
|
(declare (fixnum opos)) |
1188 |
|
(if npos |
1189 |
|
(setf (instance-ref nslots npos) (instance-ref oslots opos)) |
1190 |
|
(progn |
1191 |
|
(push name discarded) |
1192 |
|
(unless (eq (instance-ref oslots opos) *slot-unbound*) |
1193 |
|
(setf (getf plist name) (instance-ref oslots opos))))))) |
1194 |
|
;; |
1195 |
|
;; Go through all the old shared slots. |
1196 |
|
;; |
1197 |
|
(iterate ((oclass-slot-and-val (list-elements oclass-slots))) |
1198 |
|
(let ((name (car oclass-slot-and-val)) |
1199 |
|
(val (cdr oclass-slot-and-val))) |
1200 |
|
(let ((npos (posq name nlayout))) |
1201 |
|
(if npos |
1202 |
|
(setf (instance-ref nslots npos) (cdr oclass-slot-and-val)) |
1203 |
|
(progn (push name discarded) |
1204 |
|
(unless (eq val *slot-unbound*) |
1205 |
|
(setf (getf plist name) val))))))) |
1206 |
|
;; |
1207 |
|
;; Go through all the new local slots to compute the added slots. |
1208 |
|
;; |
1209 |
|
(dolist (nlocal nlayout) |
1210 |
|
(unless (or (memq nlocal olayout) |
1211 |
|
(assq nlocal oclass-slots)) |
1212 |
|
(push nlocal added))) |
1213 |
|
|
1214 |
|
(swap-wrappers-and-slots instance copy) |
1215 |
|
|
1216 |
|
(update-instance-for-redefined-class instance |
1217 |
|
added |
1218 |
|
discarded |
1219 |
|
plist) |
1220 |
|
nwrapper))) |
1221 |
|
|
1222 |
|
|
1223 |
|
;;; |
1224 |
|
;;; |
1225 |
|
;;; |
1226 |
|
(defmacro copy-instance-internal (instance) |
1227 |
|
`(#+new-kcl-wrapper if #-new-kcl-wrapper progn |
1228 |
|
#+new-kcl-wrapper (not (std-instance-p ,instance)) |
1229 |
|
(let* ((class (class-of instance)) |
1230 |
|
(copy (allocate-instance class))) |
1231 |
|
(if (std-instance-p ,instance) |
1232 |
|
(setf (std-instance-slots ,instance) (std-instance-slots ,instance)) |
1233 |
|
(setf (fsc-instance-slots ,instance) (fsc-instance-slots ,instance))) |
1234 |
|
copy) |
1235 |
|
#+new-kcl-wrapper |
1236 |
|
(copy-structure-header ,instance))) |
1237 |
|
|
1238 |
|
(defun change-class-internal (instance new-class initargs) |
1239 |
|
(let* ((old-class (class-of instance)) |
1240 |
|
(copy (allocate-instance new-class)) |
1241 |
|
(new-wrapper (get-wrapper copy)) |
1242 |
|
(old-wrapper (class-wrapper old-class)) |
1243 |
|
(old-layout (wrapper-instance-slots-layout old-wrapper)) |
1244 |
|
(new-layout (wrapper-instance-slots-layout new-wrapper)) |
1245 |
|
(old-slots (get-slots instance)) |
1246 |
|
(new-slots (get-slots copy)) |
1247 |
|
(old-class-slots (wrapper-class-slots old-wrapper))) |
1248 |
|
|
1249 |
|
;; |
1250 |
|
;; "The values of local slots specified by both the class Cto and |
1251 |
|
;; Cfrom are retained. If such a local slot was unbound, it remains |
1252 |
|
;; unbound." |
1253 |
|
;; |
1254 |
|
(loop for new-slot in new-layout and new-position from 0 |
1255 |
|
for old-position = (posq new-slot old-layout) |
1256 |
|
when old-position do |
1257 |
|
(setf (instance-ref new-slots new-position) |
1258 |
|
(instance-ref old-slots old-position))) |
1259 |
|
|
1260 |
|
;; |
1261 |
|
;; "The values of slots specified as shared in the class Cfrom and |
1262 |
|
;; as local in the class Cto are retained." |
1263 |
|
;; |
1264 |
|
(loop for (name . val) in old-class-slots |
1265 |
|
for new-position = (posq name new-layout) |
1266 |
|
when new-position do |
1267 |
|
(setf (instance-ref new-slots new-position) val)) |
1268 |
|
|
1269 |
|
;; Make the copy point to the old instance's storage, and make the |
1270 |
|
;; old instance point to the new storage. |
1271 |
|
(swap-wrappers-and-slots instance copy) |
1272 |
|
|
1273 |
|
(apply #'update-instance-for-different-class copy instance initargs) |
1274 |
|
instance)) |
1275 |
|
|
1276 |
|
(defmethod change-class ((instance standard-object) |
1277 |
|
(new-class standard-class) |
1278 |
|
&rest initargs) |
1279 |
|
(change-class-internal instance new-class initargs)) |
1280 |
|
|
1281 |
|
;; FIXME add class funcallable-standard-object ?? |
1282 |
|
;(defmethod change-class ((instance funcallable-standard-object) |
1283 |
|
; (new-class funcallable-standard-class) |
1284 |
|
; &rest initargs) |
1285 |
|
; (change-class-internal instance new-class initargs)) |
1286 |
|
|
1287 |
|
(defmethod change-class ((instance standard-object) |
1288 |
|
(new-class funcallable-standard-class) |
1289 |
|
&rest initargs) |
1290 |
|
(declare (ignore initargs)) |
1291 |
|
(error "Can't change the class of ~S to ~S~@ |
1292 |
|
because it isn't already an instance with metaclass ~S." |
1293 |
|
instance new-class 'standard-class)) |
1294 |
|
|
1295 |
|
;(defmethod change-class ((instance funcallable-standard-object) |
1296 |
|
; (new-class standard-class) |
1297 |
|
; &rest initargs) |
1298 |
|
; (declare (ignore initargs)) |
1299 |
|
; (error "Can't change the class of ~S to ~S~@ |
1300 |
|
; because it isn't already an instance with metaclass ~S." |
1301 |
|
; instance new-class 'funcallable-standard-class)) |
1302 |
|
|
1303 |
|
(defmethod change-class ((instance t) (new-class-name symbol) &rest initargs) |
1304 |
|
(apply #'change-class instance (find-class new-class-name) initargs)) |
1305 |
|
|
1306 |
|
|
1307 |
|
|
1308 |
|
|
1309 |
|
;;; |
1310 |
|
;;; The metaclass BUILT-IN-CLASS |
1311 |
|
;;; |
1312 |
|
;;; This metaclass is something of a weird creature. By this point, all |
1313 |
|
;;; instances of it which will exist have been created, and no instance |
1314 |
|
;;; is ever created by calling MAKE-INSTANCE. |
1315 |
|
;;; |
1316 |
|
;;; But, there are other parts of the protcol we must follow and those |
1317 |
|
;;; definitions appear here. |
1318 |
|
;;; |
1319 |
|
(defmethod shared-initialize :before |
1320 |
|
((class built-in-class) slot-names &rest initargs) |
1321 |
|
(declare (ignore slot-names initargs)) |
1322 |
|
(error "Attempt to initialize or reinitialize a built in class.")) |
1323 |
|
|
1324 |
|
(defmethod class-direct-slots ((class built-in-class)) ()) |
1325 |
|
(defmethod class-slots ((class built-in-class)) ()) |
1326 |
|
(defmethod class-direct-default-initargs ((class built-in-class)) ()) |
1327 |
|
(defmethod class-default-initargs ((class built-in-class)) ()) |
1328 |
|
|
1329 |
|
(defmethod validate-superclass ((c class) (s built-in-class)) |
1330 |
|
(eq s *the-class-t*)) |
1331 |
|
|
1332 |
|
|
1333 |
|
|
1334 |
|
;;; |
1335 |
|
;;; |
1336 |
|
;;; |
1337 |
|
|
1338 |
|
(defmethod validate-superclass ((c slot-class) |
1339 |
|
(f forward-referenced-class)) |
1340 |
|
't) |
1341 |
|
|
1342 |
|
|
1343 |
|
;;; |
1344 |
|
;;; |
1345 |
|
;;; |
1346 |
|
|
1347 |
|
(defmethod add-dependent ((metaobject dependent-update-mixin) dependent) |
1348 |
|
(pushnew dependent (plist-value metaobject 'dependents))) |
1349 |
|
|
1350 |
|
(defmethod remove-dependent ((metaobject dependent-update-mixin) dependent) |
1351 |
|
(setf (plist-value metaobject 'dependents) |
1352 |
|
(delete dependent (plist-value metaobject 'dependents)))) |
1353 |
|
|
1354 |
|
(defmethod map-dependents ((metaobject dependent-update-mixin) function) |
1355 |
|
(dolist (dependent (plist-value metaobject 'dependents)) |
1356 |
|
(funcall function dependent))) |
1357 |
|
|