/[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.65 - (show annotations)
Sun May 11 11:30:34 2003 UTC (10 years, 11 months ago) by gerd
Branch: MAIN
Changes since 1.64: +12 -6 lines
	More SLOT-VALUE etc. on conditions.

	* src/pcl/slots.lisp (slot-value-using-class)
	(setf slot-boundp-using-class) <condition-class>: New methods.

	* src/pcl/std-class.lisp (initialize-internal-slot-functions): Use
	slot-name->class-table.
	(shared-initialize): Call update-pv-table-cache-info.
	(compute-slots) <around condition-class>: New method.

	* src/pcl/slots-boot.lisp (ensure-accessor): Use
	slot-name->class-table.
	(get-optimized-std-accessor-method-function)
	(get-optimized-std-slot-value-using-class-method-function):
	Handle condition classes.

	* src/pcl/methods.lisp (*condition-slot-value-using-class-method*)
	(*condition-setf-slot-value-using-class-method*)
	(*condition-slot-boundp-using-class-method*): New vars.
	(condition-svuc-method, set-condition-svuc-method): New functions.
	(update-std-or-str-methods): Handle conditions.

	* src/pcl/generic-functions.lisp (condition-class-p): New gf.

	* src/pcl/dfun.lisp (make-accessor-table): Use
	slot-name->class-table.

	* src/pcl/defs.lisp (*the-condition-class*): New var.
	(slot-name->class-table): New function.
	(condition): New class.
	(*early-class-predicates*): Add condition-class-p.

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

  ViewVC Help
Powered by ViewVC 1.1.5