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

  ViewVC Help
Powered by ViewVC 1.1.5