/[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.63 - (show annotations)
Sat May 10 19:09:01 2003 UTC (10 years, 11 months ago) by gerd
Branch: MAIN
Changes since 1.62: +28 -5 lines
	SLOT-EXISTS-P is supposed to work on conditions.  Detected
	by Paul Dietz.

	* src/pcl/std-class.lisp (class-direct-slots, class-slots)
	<condition-class>: Remove methods.
	(shared-initialize) <condition-class>: Initialize direct
	and effective slots.
	(direct-slot-definition-class, effective-slot-definition-class)
	(finalize-inheritance, shared-initialize) <condition-class>:
	New methods.

	* src/pcl/braid.lisp (ensure-non-standard-class): Pass slot
	initargs to ensure-class for condition classes.

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

  ViewVC Help
Powered by ViewVC 1.1.5