/[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.50 - (show annotations)
Sun Apr 6 09:10:09 2003 UTC (11 years ago) by gerd
Branch: MAIN
Changes since 1.49: +61 -24 lines
	Fix TYPEP/SUBTYPEP problems with unfinalized and
	forward-referenced classes.

	* pcl/std-class.lisp (class-finalized-p): Method removed.
	(*allow-forward-referenced-classes-in-cpl-p*): New variable.
	(make-preliminary-layout): New function.
	(shared-initialize) <:after std-class>: Call
	make-preliminary-layout.
	(shared-initialize) <:after forward-referenced-class>: New method
	calling make-preliminary-layout.
	(shared-initialize) <:after structure-class>: Set finalized-p slot
	to true.
	(update-slots): Likewise.
	(shared-initialize) <:after condition-class>: Likewise.
	(inform-type-system-about-class): New method for
	forward-referenced classes.
	(class-has-a-forward-referenced-superclass-p): Moved to info.lisp.

	* pcl/cpl.lisp (compute-std-cpl-phase-1): Allow forward-referenced
	classes in the cpl if *allow-forward-referenced-classes-in-cpl-p*
	is true.

	* info.lisp (class-has-a-forward-referenced-superclass-p): Moved
	here from std-class.lisp.

	* pcl/cache.lisp (make-wrapper): Handle forward-referenced
	classes.

	* pcl/braid.lisp (bootstrap-initialize-class): Set the finalized-p
	slot.

	* pcl/defs.lisp (class): Add slot finalized-p.

	* pcl/rt/defclass.lisp (defclass-types.[0-5])
	(defclass-forward-referenced-class.0): New tests.

	Misc fixes.

	* pcl/defclass.lisp (expand-defclass): Remove code papering
	over a potential compiler bug.

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

  ViewVC Help
Powered by ViewVC 1.1.5