/[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.82.4.2 - (show annotations)
Mon Mar 16 21:10:56 2009 UTC (5 years, 1 month ago) by rtoy
Branch: unicode-utf16-branch
CVS Tags: unicode-utf16-sync-label-2009-03-16, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25
Changes since 1.82.4.1: +1 -3 lines
Sync to CVS HEAD, tag label-2009-03-16.

But don't sync Config.FreeBSD_gencgc, Config.x86_freebsd,
FreeBSD-os.c, and FreeBSD-os.h.  Let Alex sync those later.

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

  ViewVC Help
Powered by ViewVC 1.1.5