/[cmucl]/src/pcl/std-class.lisp
ViewVC logotype

Contents of /src/pcl/std-class.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.46 - (show annotations)
Fri Mar 28 16:07:42 2003 UTC (11 years ago) by gerd
Branch: MAIN
Changes since 1.45: +3 -2 lines
	Break some vicious metacircles.

	* pcl/dfun.lisp (*standard-classes*, *standard-slot-locations*):
	New variables.
	(compute-standard-slot-locations, standard-slot-value)
	(standard-slot-value/gf, standard-slot-value/method)
	(standard-slot-value/eslotd, standard-slot-value/class)
	(maybe-update-standard-class-locations): New functions.
	(*cmv-stack*): New variable.
	(cache-miss-values-internal): Use it to detect vicious circles,
	and call break-vicious-metacircle.
	(break-vicious-metacircle, accesses-standard-class-slot-p)
	(find-standard-class-accessor-method): New functions.

	* pcl/std-class.lisp (update-slots): Call
	maybe-update-standard-class-locations.

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

  ViewVC Help
Powered by ViewVC 1.1.5