/[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.40 - (show annotations)
Fri Jan 3 20:17:49 2003 UTC (11 years, 3 months ago) by pmai
Branch: MAIN
Changes since 1.39: +16 -1 lines
Entomotomy Bug: finalize-instance-not-being-called-on-class-finalization

Fix to ensure that finalize-inheritance (the bug's name is a misnomer) is
called on class-finalization, from Gerd Moellmann via SBCL.
1 ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
2 ;;;
3 ;;; *************************************************************************
4 ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5 ;;; All rights reserved.
6 ;;;
7 ;;; Use and copying of this software and preparation of derivative works
8 ;;; based upon this software are permitted. Any distribution of this
9 ;;; software or derivative works must comply with all applicable United
10 ;;; States export control laws.
11 ;;;
12 ;;; This software is made available AS IS, and Xerox Corporation makes no
13 ;;; warranty about the software, its performance or its conformity to any
14 ;;; specification.
15 ;;;
16 ;;; Any person obtaining a copy of this software is requested to send their
17 ;;; name and post office or electronic mail address to:
18 ;;; CommonLoops Coordinator
19 ;;; Xerox PARC
20 ;;; 3333 Coyote Hill Rd.
21 ;;; Palo Alto, CA 94304
22 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23 ;;;
24 ;;; Suggestions, comments and requests for improvements are also welcome.
25 ;;; *************************************************************************
26 ;;;
27
28 (ext:file-comment
29 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/std-class.lisp,v 1.40 2003/01/03 20:17:49 pmai Exp $")
30 ;;;
31
32 (in-package :pcl)
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 (let ((table (or (gethash name *name->class->slotd-table*)
81 (setf (gethash name *name->class->slotd-table*)
82 (make-hash-table :test 'eq :size 5)))))
83 (setf (gethash class table) slotd))
84 (dolist (type '(reader writer boundp))
85 (let* ((gf-name (ecase type
86 (reader 'slot-value-using-class)
87 (writer '(setf slot-value-using-class))
88 (boundp 'slot-boundp-using-class)))
89 (gf (gdefinition gf-name)))
90 (compute-slot-accessor-info slotd type gf)))
91 (initialize-internal-slot-gfs name)))
92
93 (defmethod compute-slot-accessor-info ((slotd effective-slot-definition) type gf)
94 (let* ((name (slot-value slotd 'name))
95 (class (slot-value slotd 'class))
96 (old-slotd (find-slot-definition class name))
97 (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
98 (multiple-value-bind (function std-p)
99 (if (eq *boot-state* 'complete)
100 (get-accessor-method-function gf type class slotd)
101 (get-optimized-std-accessor-method-function class slotd type))
102 (setf (slot-accessor-std-p slotd type) std-p)
103 (setf (slot-accessor-function slotd type) function))
104 (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all))))
105 (push (cons class name) *pv-table-cache-update-info*))))
106
107 (defmethod slot-definition-allocation ((slotd structure-slot-definition))
108 :instance)
109
110
111
112 (defmethod shared-initialize :after ((object documentation-mixin)
113 slot-names
114 &key (documentation nil documentation-p))
115 (declare (ignore slot-names))
116 (when documentation-p
117 (setf (plist-value object 'documentation) documentation)))
118
119 (defmethod documentation (object doc-type)
120 (declare (ignore object doc-type))
121 nil)
122
123 (defmethod (setf documentation) (new-value object doc-type)
124 (declare (ignore new-value doc-type))
125 (error "Can't change the documentation of ~S." object))
126
127 (defmethod documentation ((object documentation-mixin) doc-type)
128 (declare (ignore doc-type))
129 (plist-value object 'documentation))
130
131 (defmethod (setf documentation) (new-value (object documentation-mixin) doc-type)
132 (declare (ignore doc-type))
133 (setf (plist-value object 'documentation) new-value))
134
135
136 (defmethod documentation ((slotd standard-slot-definition) doc-type)
137 (declare (ignore doc-type))
138 (slot-value slotd 'documentation))
139
140 (defmethod (setf documentation) (new-value (slotd standard-slot-definition) doc-type)
141 (declare (ignore doc-type))
142 (setf (slot-value slotd 'documentation) new-value))
143
144
145 ;;;
146 ;;; Various class accessors that are a little more complicated than can be
147 ;;; done with automatically generated reader methods.
148 ;;;
149 (defmethod class-finalized-p ((class pcl-class))
150 (with-slots (wrapper) class
151 (not (null wrapper))))
152
153 (defmethod class-prototype ((class std-class))
154 (with-slots (prototype) class
155 (or prototype (setq prototype (allocate-instance class)))))
156
157 (defmethod class-prototype ((class structure-class))
158 (with-slots (prototype wrapper defstruct-constructor) class
159 (or prototype
160 (setq prototype
161 (if defstruct-constructor
162 (allocate-instance class)
163 (allocate-standard-instance wrapper))))))
164
165 (defmethod class-direct-default-initargs ((class slot-class))
166 (plist-value class 'direct-default-initargs))
167
168 (defmethod class-default-initargs ((class slot-class))
169 (plist-value class 'default-initargs))
170
171 (defmethod class-constructors ((class slot-class))
172 (plist-value class 'constructors))
173
174 (defmethod class-slot-cells ((class std-class))
175 (plist-value class 'class-slot-cells))
176
177
178 ;;;
179 ;;; Class accessors that are even a little bit more complicated than those
180 ;;; above. These have a protocol for updating them, we must implement that
181 ;;; protocol.
182 ;;;
183
184 ;;;
185 ;;; Maintaining the direct subclasses backpointers. The update methods are
186 ;;; here, the values are read by an automatically generated reader method.
187 ;;;
188 (defmethod add-direct-subclass ((class class) (subclass class))
189 (with-slots (direct-subclasses) class
190 (pushnew subclass direct-subclasses)
191 subclass))
192
193 (defmethod remove-direct-subclass ((class class) (subclass class))
194 (with-slots (direct-subclasses) class
195 (setq direct-subclasses (remove subclass direct-subclasses))
196 subclass))
197
198 ;;;
199 ;;; Maintaining the direct-methods and direct-generic-functions backpointers.
200 ;;;
201 ;;; There are four generic functions involved, each has one method for the
202 ;;; class case and another method for the damned EQL specializers. All of
203 ;;; these are specified methods and appear in their specified place in the
204 ;;; class graph.
205 ;;;
206 ;;; ADD-DIRECT-METHOD
207 ;;; REMOVE-DIRECT-METHOD
208 ;;; SPECIALIZER-DIRECT-METHODS
209 ;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
210 ;;;
211 ;;; In each case, we maintain one value which is a cons. The car is the list
212 ;;; methods. The cdr is a list of the generic functions. The cdr is always
213 ;;; computed lazily.
214 ;;;
215
216 (defmethod add-direct-method ((specializer class) (method method))
217 (with-slots (direct-methods) specializer
218 (setf (car direct-methods) (adjoin method (car direct-methods)) ;PUSH
219 (cdr direct-methods) ()))
220 method)
221
222 (defmethod remove-direct-method ((specializer class) (method method))
223 (with-slots (direct-methods) specializer
224 (setf (car direct-methods) (remove method (car direct-methods))
225 (cdr direct-methods) ()))
226 method)
227
228 (defmethod specializer-direct-methods ((specializer class))
229 (with-slots (direct-methods) specializer
230 (car direct-methods)))
231
232 (defmethod specializer-direct-generic-functions ((specializer class))
233 (with-slots (direct-methods) specializer
234 (or (cdr direct-methods)
235 (setf (cdr direct-methods)
236 (loop for method in (car direct-methods)
237 for generic-function = (method-generic-function method)
238 unless (member generic-function collected :test #'eq)
239 collect generic-function into collected
240 finally (return collected))))))
241
242
243 ;;;
244 ;;; This hash table is used to store the direct methods and direct generic
245 ;;; functions of EQL specializers. Each value in the table is the cons.
246 ;;;
247 (defvar *eql-specializer-methods* (make-hash-table :test #'eql))
248 (defvar *class-eq-specializer-methods* (make-hash-table :test #'eq))
249
250 (defmethod specializer-method-table ((specializer eql-specializer))
251 *eql-specializer-methods*)
252
253 (defmethod specializer-method-table ((specializer class-eq-specializer))
254 *class-eq-specializer-methods*)
255
256 (defmethod add-direct-method ((specializer specializer-with-object) (method method))
257 (let* ((object (specializer-object specializer))
258 (table (specializer-method-table specializer))
259 (entry (gethash object table)))
260 (unless entry
261 (setq entry
262 (setf (gethash object table)
263 (cons nil nil))))
264 (setf (car entry) (adjoin method (car entry))
265 (cdr entry) ())
266 method))
267
268 (defmethod remove-direct-method ((specializer specializer-with-object) (method method))
269 (let* ((object (specializer-object specializer))
270 (entry (gethash object (specializer-method-table specializer))))
271 (when entry
272 (setf (car entry) (remove method (car entry))
273 (cdr entry) ()))
274 method))
275
276 (defmethod specializer-direct-methods ((specializer specializer-with-object))
277 (car (gethash (specializer-object specializer)
278 (specializer-method-table specializer))))
279
280 (defmethod specializer-direct-generic-functions ((specializer specializer-with-object))
281 (let* ((object (specializer-object specializer))
282 (entry (gethash object (specializer-method-table specializer))))
283 (when entry
284 (or (cdr entry)
285 (setf (cdr entry)
286 (loop for method in (car entry)
287 for generic-function = (method-generic-function method)
288 unless (member generic-function collected :test #'eq)
289 collect generic-function into collected
290 finally (return collected)))))))
291
292 (defun map-specializers (function)
293 (map-all-classes (lambda (class)
294 (funcall function (class-eq-specializer class))
295 (funcall function class)))
296 (maphash (lambda (object methods)
297 (declare (ignore methods))
298 (intern-eql-specializer object))
299 *eql-specializer-methods*)
300 (maphash (lambda (object specl)
301 (declare (ignore object))
302 (funcall function specl))
303 *eql-specializer-table*)
304 nil)
305
306 (defun map-all-generic-functions (function)
307 (let ((all-generic-functions (make-hash-table :test 'eq)))
308 (map-specializers (lambda (specl)
309 (dolist (gf (specializer-direct-generic-functions specl))
310 (unless (gethash gf all-generic-functions)
311 (setf (gethash gf all-generic-functions) t)
312 (funcall function gf))))))
313 nil)
314
315 (defmethod shared-initialize :after ((specl class-eq-specializer) slot-names &key)
316 (declare (ignore slot-names))
317 (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
318
319 (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
320 (declare (ignore slot-names))
321 (setf (slot-value specl 'type) `(eql ,(specializer-object specl))))
322
323
324
325 (defun real-load-defclass (name metaclass-name supers slots other)
326 (let ((res (apply #'ensure-class name :metaclass metaclass-name
327 :direct-superclasses supers
328 :direct-slots slots
329 :definition-source `((defclass ,name)
330 ,*load-pathname*)
331 other)))
332 ;; Defclass of a class with a forward-referenced superclass does not
333 ;; have a wrapper. RES is the incomplete PCL class. The Lisp class
334 ;; does not yet exist. Maybe should return NIL in that case as RES
335 ;; is not useful to the user?
336 (and (class-wrapper res)(kernel:layout-class (class-wrapper res)))))
337
338 (setf (gdefinition 'load-defclass) #'real-load-defclass)
339
340 (defun ensure-class (name &rest all)
341 (apply #'ensure-class-using-class name (find-class name nil) all))
342
343 (defmethod ensure-class-using-class (name (class null) &rest args &key)
344 (multiple-value-bind (meta initargs)
345 (ensure-class-values class args)
346 (inform-type-system-about-class (class-prototype meta) name);***
347 (setf class (apply #'make-instance meta :name name initargs)
348 (find-class name) class)
349 (inform-type-system-about-class class name) ;***
350 class))
351
352 (defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
353 (multiple-value-bind (meta initargs)
354 (ensure-class-values class args)
355 (unless (eq (class-of class) meta) (change-class class meta))
356 (apply #'reinitialize-instance class initargs)
357 (setf (find-class name) class)
358 (inform-type-system-about-class class name) ;***
359 class))
360
361 (defmethod class-predicate-name ((class t))
362 'function-returning-nil)
363
364 (defun ensure-class-values (class args)
365 (let* ((initargs (copy-list args))
366 (unsupplied (list 1))
367 (supplied-meta (getf initargs :metaclass unsupplied))
368 (supplied-supers (getf initargs :direct-superclasses unsupplied))
369 (meta
370 (cond ((neq supplied-meta unsupplied)
371 (find-class supplied-meta))
372 ((or (null class)
373 (forward-referenced-class-p class))
374 *the-class-standard-class*)
375 (t
376 (class-of class)))))
377 (flet ((fix-super (s)
378 (cond ((classp s) s)
379 ((not (legal-class-name-p s))
380 (simple-program-error
381 "~S is not a class or a legal class name." s))
382 (t
383 (or (find-class s nil)
384 (setf (find-class s)
385 (make-instance 'forward-referenced-class
386 :name s)))))))
387 ;;
388 ;; CLHS: signal PROGRAM-ERROR, if
389 ;; (a) there are any duplicate slot names
390 ;; (b) any of the slot options :ALLOCATION, :INITFORM, :TYPE, or
391 ;; :DOCUMENTATION appears more than one in a single slot description.
392 (loop for (slot . more) on (getf initargs :direct-slots)
393 for slot-name = (getf slot :name)
394 if (some (lambda (s) (eq slot-name (getf s :name))) more) do
395 (simple-program-error
396 "More than one direct slot with name ~S."
397 slot-name)
398 else do
399 (loop for (option value . more) on slot by #'cddr
400 when (and (member option '(:allocation :type :initform
401 :documentation))
402 (not (eq unsupplied
403 (getf more option unsupplied)))) do
404 (simple-program-error
405 "Duplicate slot option ~S for slot ~S."
406 option slot-name)))
407 ;;
408 ;; CLHS: signal PROGRAM-ERROR, if an initialization argument name
409 ;; appears more than once in :DEFAULT-INITARGS class option.
410 (loop for (initarg . more) on (getf initargs :direct-default-initargs)
411 for name = (car initarg)
412 when (some (lambda (a) (eq (car a) name)) more) do
413 (simple-program-error
414 "Duplicate initialization argument ~
415 name ~S in :default-initargs of class ~A."
416 name class))
417 ;;
418 (loop (unless (remf initargs :metaclass) (return)))
419 (loop (unless (remf initargs :direct-superclasses) (return)))
420 (values meta
421 (nconc
422 (when (neq supplied-supers unsupplied)
423 (list
424 :direct-superclasses
425 (mapcar #'fix-super supplied-supers)))
426 initargs)))))
427
428
429 ;;;
430 ;;;
431 ;;;
432 #|| ; since it doesn't do anything
433 (defmethod shared-initialize :before ((class std-class)
434 slot-names
435 &key direct-superclasses)
436 (declare (ignore slot-names))
437 ;; *** error checking
438 )
439 ||#
440
441 (defmethod shared-initialize :after
442 ((class std-class)
443 slot-names
444 &key (direct-superclasses nil direct-superclasses-p)
445 (direct-slots nil direct-slots-p)
446 (direct-default-initargs nil direct-default-initargs-p)
447 (predicate-name nil predicate-name-p))
448 (declare (ignore slot-names))
449 (cond ((or direct-superclasses-p
450 (null (slot-value class 'direct-superclasses)))
451 (setq direct-superclasses
452 (or direct-superclasses
453 (list (if (funcallable-standard-class-p class)
454 *the-class-funcallable-standard-object*
455 *the-class-standard-object*))))
456 (dolist (superclass direct-superclasses)
457 (unless (validate-superclass class superclass)
458 (error "The class ~S was specified as a~%
459 super-class of the class ~S;~%~
460 but the meta-classes ~S and~%~S are incompatible.~@
461 Define a method for ~S to avoid this error."
462 superclass class (class-of superclass) (class-of class)
463 'validate-superclass)))
464 (setf (slot-value class 'direct-superclasses) direct-superclasses))
465 (t
466 (setq direct-superclasses (slot-value class 'direct-superclasses))))
467 (setq direct-slots
468 (if direct-slots-p
469 (setf (slot-value class 'direct-slots)
470 (mapcar (lambda (pl) (make-direct-slotd class pl)) direct-slots))
471 (slot-value class 'direct-slots)))
472 (if direct-default-initargs-p
473 (setf (plist-value class 'direct-default-initargs) direct-default-initargs)
474 (setq direct-default-initargs (plist-value class 'direct-default-initargs)))
475 (setf (plist-value class 'class-slot-cells)
476 (let ((collected ()))
477 (dolist (dslotd direct-slots (nreverse collected))
478 (when (eq (slot-definition-allocation dslotd) :class)
479 (let ((initfunction (slot-definition-initfunction dslotd)))
480 (push (cons (slot-definition-name dslotd)
481 (if initfunction
482 (funcall initfunction)
483 +slot-unbound+))
484 collected))))))
485 (setq predicate-name (if predicate-name-p
486 (setf (slot-value class 'predicate-name)
487 (car predicate-name))
488 (or (slot-value class 'predicate-name)
489 (setf (slot-value class 'predicate-name)
490 (make-class-predicate-name (class-name class))))))
491 (add-direct-subclasses class direct-superclasses)
492 (update-class class nil)
493 (make-class-predicate class predicate-name)
494 (add-slot-accessors class direct-slots))
495
496 (defmethod shared-initialize :before ((class class) slot-names &key name)
497 (declare (ignore slot-names name))
498 (setf (slot-value class 'type) `(class ,class))
499 (setf (slot-value class 'class-eq-specializer)
500 (make-instance 'class-eq-specializer :class class)))
501
502 (defmethod reinitialize-instance :before ((class slot-class)
503 &key direct-superclasses)
504 (remove-direct-subclasses class direct-superclasses)
505 (remove-slot-accessors class (class-direct-slots class)))
506
507 (defmethod reinitialize-instance :after ((class slot-class)
508 &rest initargs
509 &key)
510 (map-dependents class
511 (lambda (dependent)
512 (apply #'update-dependent class dependent initargs))))
513
514 (defmethod shared-initialize :after
515 ((class structure-class)
516 slot-names
517 &key (direct-superclasses nil direct-superclasses-p)
518 (direct-slots nil direct-slots-p)
519 direct-default-initargs
520 (predicate-name nil predicate-name-p))
521 (declare (ignore slot-names direct-default-initargs))
522 (if direct-superclasses-p
523 (setf (slot-value class 'direct-superclasses)
524 (or direct-superclasses
525 (setq direct-superclasses
526 (and (not (eq (class-name class) 'structure-object))
527 (list *the-class-structure-object*)))))
528 (setq direct-superclasses (slot-value class 'direct-superclasses)))
529 (let* ((name (class-name class))
530 (from-defclass-p (slot-value class 'from-defclass-p))
531 (defstruct-p (or from-defclass-p (not (structure-type-p name)))))
532 (if direct-slots-p
533 (setf (slot-value class 'direct-slots)
534 (setq direct-slots
535 (mapcar (lambda (pl)
536 (when defstruct-p
537 (let* ((slot-name (getf pl :name))
538 (acc-name (format nil "~s structure class ~a"
539 name slot-name))
540 (accessor (intern acc-name)))
541 (setq pl (list* :defstruct-accessor-symbol accessor
542 pl))))
543 (make-direct-slotd class pl))
544 direct-slots)))
545 (setq direct-slots (slot-value class 'direct-slots)))
546 (when defstruct-p
547 (let* ((include (car (slot-value class 'direct-superclasses)))
548 (conc-name (intern (format nil "~s structure class " name)))
549 (constructor (intern (format nil "~a constructor" conc-name)))
550 (defstruct `(defstruct (,name
551 ,@(when include
552 `((:include ,(class-name include))))
553 (:predicate nil)
554 (:conc-name ,conc-name)
555 (:constructor ,constructor ()))
556 ,@(mapcar (lambda (slot)
557 `(,(slot-definition-name slot)
558 +slot-unbound+))
559 direct-slots)))
560 (reader-names (mapcar (lambda (slotd)
561 (intern (format nil "~A~A reader" conc-name
562 (slot-definition-name slotd))))
563 direct-slots))
564 (writer-names (mapcar (lambda (slotd)
565 (intern (format nil "~A~A writer" conc-name
566 (slot-definition-name slotd))))
567 direct-slots))
568 (readers-init
569 (mapcar (lambda (slotd reader-name)
570 (let ((accessor
571 (slot-definition-defstruct-accessor-symbol slotd)))
572 `(defun ,reader-name (obj)
573 (declare (type ,name obj))
574 (,accessor obj))))
575 direct-slots reader-names))
576 (writers-init
577 (mapcar (lambda (slotd writer-name)
578 (let ((accessor
579 (slot-definition-defstruct-accessor-symbol slotd)))
580 `(defun ,writer-name (nv obj)
581 (declare (type ,name obj))
582 (setf (,accessor obj) nv))))
583 direct-slots writer-names))
584 (defstruct-form
585 `(progn
586 ,defstruct
587 ,@readers-init ,@writers-init)))
588 (unless (structure-type-p name) (eval defstruct-form))
589 (mapc (lambda (dslotd reader-name writer-name)
590 (let* ((reader (gdefinition reader-name))
591 (writer (when (fboundp writer-name)
592 (gdefinition writer-name))))
593 (setf (slot-value dslotd 'internal-reader-function) reader)
594 (setf (slot-value dslotd 'internal-writer-function) writer)))
595 direct-slots reader-names writer-names)
596 (setf (slot-value class 'defstruct-form) defstruct-form)
597 (setf (slot-value class 'defstruct-constructor) constructor))))
598 (add-direct-subclasses class direct-superclasses)
599 (setf (slot-value class 'class-precedence-list)
600 (compute-class-precedence-list class))
601 (setf (slot-value class 'slots) (compute-slots class))
602 (let ((lclass (lisp:find-class (class-name class))))
603 (setf (kernel:class-pcl-class lclass) class)
604 (setf (slot-value class 'wrapper) (kernel:class-layout lclass)))
605 (update-pv-table-cache-info class)
606 (setq predicate-name (if predicate-name-p
607 (setf (slot-value class 'predicate-name)
608 (car predicate-name))
609 (or (slot-value class 'predicate-name)
610 (setf (slot-value class 'predicate-name)
611 (make-class-predicate-name (class-name class))))))
612 (make-class-predicate class predicate-name)
613 (add-slot-accessors class direct-slots))
614
615 (defmethod direct-slot-definition-class ((class structure-class) initargs)
616 (declare (ignore initargs))
617 (find-class 'structure-direct-slot-definition))
618
619 (defmethod finalize-inheritance ((class structure-class))
620 nil) ; always finalized
621
622 (defun add-slot-accessors (class dslotds)
623 (fix-slot-accessors class dslotds 'add))
624
625 (defun remove-slot-accessors (class dslotds)
626 (fix-slot-accessors class dslotds 'remove))
627
628 (defun fix-slot-accessors (class dslotds add/remove)
629 (flet ((fix (gfspec name r/w)
630 (let ((gf (ensure-generic-function gfspec)))
631 (case r/w
632 (r (if (eq add/remove 'add)
633 (add-reader-method class gf name)
634 (remove-reader-method class gf)))
635 (w (if (eq add/remove 'add)
636 (add-writer-method class gf name)
637 (remove-writer-method class gf)))))))
638 (dolist (dslotd dslotds)
639 (let ((slot-name (slot-definition-name dslotd)))
640 (dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r))
641 (dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w))))))
642
643
644 (defun add-direct-subclasses (class new)
645 (dolist (n new)
646 (unless (memq class (class-direct-subclasses class))
647 (add-direct-subclass n class))))
648
649 (defun remove-direct-subclasses (class new)
650 (let ((old (class-direct-superclasses class)))
651 (dolist (o (set-difference old new))
652 (remove-direct-subclass o class))))
653
654
655 ;;;
656 ;;;
657 ;;;
658 (defmethod finalize-inheritance ((class std-class))
659 (update-class class t))
660
661
662 (defun class-has-a-forward-referenced-superclass-p (class)
663 (or (forward-referenced-class-p class)
664 (some #'class-has-a-forward-referenced-superclass-p
665 (class-direct-superclasses class))))
666
667 ;;;
668 ;;; Called by :after shared-initialize whenever a class is initialized or
669 ;;; reinitialized. The class may or may not be finalized.
670 ;;;
671 (defun update-class (class finalizep)
672 ;; Comment from Gerd Moellmann:
673 ;;
674 ;; Note that we can't simply delay the finalization when CLASS has
675 ;; no forward referenced superclasses because that causes bootstrap
676 ;; problems.
677 (when (and (not finalizep)
678 (not (class-finalized-p class))
679 (not (class-has-a-forward-referenced-superclass-p class)))
680 (finalize-inheritance class)
681 (return-from update-class))
682 (when (or finalizep (class-finalized-p class)
683 (not (class-has-a-forward-referenced-superclass-p class)))
684 (update-cpl class (compute-class-precedence-list class))
685 ;; This invocation of UPDATE-SLOTS, in practice, finalizes the
686 ;; class. The hoops above are to ensure that FINALIZE-INHERITANCE
687 ;; is called at finalization, so that MOP programmers can hook
688 ;; into the system as described in "Class Finalization Protocol"
689 ;; (section 5.5.2 of AMOP).
690 (update-slots class (compute-slots class))
691 (update-gfs-of-class class)
692 (update-inits class (compute-default-initargs class))
693 (update-make-instance-function-table class))
694 (unless finalizep
695 (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))
696
697 (defun update-cpl (class cpl)
698 (if (class-finalized-p class)
699 (unless (equal (class-precedence-list class) cpl)
700 ;; Need to have the cpl setup before update-lisp-class-layout
701 ;; is called on CMUCL.
702 (setf (slot-value class 'class-precedence-list) cpl)
703 (force-cache-flushes class))
704 (setf (slot-value class 'class-precedence-list) cpl))
705 (update-class-can-precede-p cpl))
706
707 (defun update-class-can-precede-p (cpl)
708 (when cpl
709 (let ((first (car cpl)))
710 (dolist (c (cdr cpl))
711 (pushnew c (slot-value first 'can-precede-list))))
712 (update-class-can-precede-p (cdr cpl))))
713
714 (defun class-can-precede-p (class1 class2)
715 (member class2 (class-can-precede-list class1)))
716
717 (defun update-slots (class eslotds)
718 (let ((instance-slots ())
719 (class-slots ()))
720 (dolist (eslotd eslotds)
721 (ecase (slot-definition-allocation eslotd)
722 (:instance (push eslotd instance-slots))
723 (:class (push eslotd class-slots))))
724 ;;
725 ;; If there is a change in the shape of the instances then the
726 ;; old class is now obsolete.
727 ;;
728 (let* ((nlayout (mapcar #'slot-definition-name
729 (sort instance-slots #'< :key #'slot-definition-location)))
730 (nslots (length nlayout))
731 (nwrapper-class-slots (compute-class-slots class-slots))
732 (owrapper (class-wrapper class))
733 (olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
734 (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
735 (nwrapper
736 (cond ((null owrapper)
737 (make-wrapper nslots class))
738 ((and (equal nlayout olayout)
739 (every (lambda (o n) (eq (car o) (car n)))
740 owrapper-class-slots nwrapper-class-slots))
741 owrapper)
742 (t
743 ;;
744 ;; This will initialize the new wrapper to have the same
745 ;; state as the old wrapper. We will then have to change
746 ;; that. This may seem like wasted work (it is), but the
747 ;; spec requires that we call make-instances-obsolete.
748 ;;
749 (make-instances-obsolete class)
750 (class-wrapper class)))))
751
752 (with-slots (wrapper slots) class
753 (update-lisp-class-layout class nwrapper)
754 (setf slots eslotds
755 (wrapper-instance-slots-layout nwrapper) nlayout
756 (wrapper-class-slots nwrapper) nwrapper-class-slots
757 (wrapper-no-of-instance-slots nwrapper) nslots
758 wrapper nwrapper))
759
760 (unless (eq owrapper nwrapper)
761 (update-pv-table-cache-info class)))))
762
763 (defun compute-class-slots (eslotds)
764 (loop for eslotd in eslotds
765 for name = (slot-definition-name eslotd)
766 and class = (slot-definition-class eslotd)
767 collect (assoc name (class-slot-cells class))))
768
769 (defun update-gfs-of-class (class)
770 (when (and (class-finalized-p class)
771 (let ((cpl (class-precedence-list class)))
772 (or (member *the-class-slot-class* cpl)
773 (member *the-class-standard-effective-slot-definition* cpl))))
774 (let ((gf-table (make-hash-table :test 'eq)))
775 (labels ((collect-gfs (class)
776 (dolist (gf (specializer-direct-generic-functions class))
777 (setf (gethash gf gf-table) t))
778 (mapc #'collect-gfs (class-direct-superclasses class))))
779 (collect-gfs class)
780 (maphash (lambda (gf ignore)
781 (declare (ignore ignore))
782 (update-gf-dfun class gf))
783 gf-table)))))
784
785 (defun update-inits (class inits)
786 (setf (plist-value class 'default-initargs) inits))
787
788
789 ;;;
790 ;;;
791 ;;;
792 (defmethod compute-default-initargs ((class slot-class))
793 (let ((cpl (class-precedence-list class))
794 (direct (class-direct-default-initargs class)))
795 (labels ((walk (tail)
796 (if (null tail)
797 nil
798 (let ((c (pop tail)))
799 (append (if (eq c class)
800 direct
801 (class-direct-default-initargs c))
802 (walk tail))))))
803 (let ((initargs (walk cpl)))
804 (delete-duplicates initargs :test #'eq :key #'car :from-end t)))))
805
806
807 ;;;
808 ;;; Protocols for constructing direct and effective slot definitions.
809 ;;;
810 ;;;
811 ;;;
812 ;;;
813 (defmethod direct-slot-definition-class ((class std-class) initargs)
814 (declare (ignore initargs))
815 (find-class 'standard-direct-slot-definition))
816
817 (defun make-direct-slotd (class initargs)
818 (let ((initargs (list* :class class initargs)))
819 (apply #'make-instance (direct-slot-definition-class class initargs) initargs)))
820
821 ;;;
822 ;;;
823 ;;;
824 (defmethod compute-slots ((class std-class))
825 ;;
826 ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
827 ;; for each different slot name we find in our superclasses. Each
828 ;; call receives the class and a list of the dslotds with that name.
829 ;; The list is in most-specific-first order.
830 ;;
831 (let ((name-dslotds-alist ()))
832 (dolist (c (class-precedence-list class))
833 (dolist (slot (class-direct-slots c))
834 (let* ((name (slot-definition-name slot))
835 (entry (assq name name-dslotds-alist)))
836 (if entry
837 (push slot (cdr entry))
838 (push (list name slot) name-dslotds-alist)))))
839 (mapcar (lambda (direct)
840 (compute-effective-slot-definition class
841 (nreverse (cdr direct))))
842 name-dslotds-alist)))
843
844 (defmethod compute-slots ((class standard-class))
845 (call-next-method))
846
847 (defmethod compute-slots :around ((class standard-class))
848 (let ((eslotds (call-next-method))
849 (location -1))
850 (dolist (eslotd eslotds eslotds)
851 (setf (slot-definition-location eslotd)
852 (ecase (slot-definition-allocation eslotd)
853 (:instance
854 (incf location))
855 (:class
856 (let* ((name (slot-definition-name eslotd))
857 (from-class (slot-definition-allocation-class eslotd))
858 (cell (assq name (class-slot-cells from-class))))
859 (assert (consp cell))
860 cell))))
861 (initialize-internal-slot-functions eslotd))))
862
863 (defmethod compute-slots ((class funcallable-standard-class))
864 (call-next-method))
865
866 (defmethod compute-slots :around ((class funcallable-standard-class))
867 (labels ((instance-slot-names (slotds)
868 (let (collect)
869 (dolist (slotd slotds (nreverse collect))
870 (when (eq (slot-definition-allocation slotd) :instance)
871 (push (slot-definition-name slotd) collect)))))
872 ;; This sorts slots so that slots of classes later in the CPL
873 ;; come before slots of other classes. This is crucial for
874 ;; funcallable instances because it ensures that the slots of
875 ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of
876 ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn
877 ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as
878 ;; a funcallable instance.
879 (compute-layout (eslotds)
880 (let ((first ())
881 (names (instance-slot-names eslotds)))
882 (dolist (class
883 (reverse (class-precedence-list class))
884 (nreverse (nconc names first)))
885 (dolist (ss (class-slots class))
886 (let ((name (slot-definition-name ss)))
887 (when (member name names)
888 (push name first)
889 (setq names (delete name names)))))))))
890 (let ((all-slotds (call-next-method))
891 (instance-slots ())
892 (class-slots ()))
893 (dolist (slotd all-slotds)
894 (ecase (slot-definition-allocation slotd)
895 (:instance (push slotd instance-slots))
896 (:class (push slotd class-slots))))
897 (let ((layout (compute-layout instance-slots)))
898 (dolist (slotd instance-slots)
899 (setf (slot-definition-location slotd)
900 (position (slot-definition-name slotd) layout))
901 (initialize-internal-slot-functions slotd)))
902 (dolist (slotd class-slots)
903 (let ((name (slot-definition-name slotd))
904 (from-class (slot-definition-allocation-class slotd)))
905 (setf (slot-definition-location slotd)
906 (assoc name (class-slot-cells from-class)))
907 (assert (consp (slot-definition-location slotd)))
908 (initialize-internal-slot-functions slotd)))
909 all-slotds)))
910
911 (defmethod compute-slots ((class structure-class))
912 (mapcan (lambda (superclass)
913 (mapcar (lambda (dslotd)
914 (compute-effective-slot-definition class (list dslotd)))
915 (class-direct-slots superclass)))
916 (reverse (slot-value class 'class-precedence-list))))
917
918 (defmethod compute-slots :around ((class structure-class))
919 (let ((eslotds (call-next-method)))
920 (mapc #'initialize-internal-slot-functions eslotds)
921 eslotds))
922
923 (defmethod compute-effective-slot-definition ((class slot-class) dslotds)
924 (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
925 (class (effective-slot-definition-class class initargs)))
926 (apply #'make-instance class initargs)))
927
928 (defmethod effective-slot-definition-class ((class std-class) initargs)
929 (declare (ignore initargs))
930 (find-class 'standard-effective-slot-definition))
931
932 (defmethod effective-slot-definition-class ((class structure-class) initargs)
933 (declare (ignore initargs))
934 (find-class 'structure-effective-slot-definition))
935
936 (defmethod compute-effective-slot-definition-initargs
937 ((class slot-class) direct-slotds)
938 (let* ((name nil)
939 (initfunction nil)
940 (initform nil)
941 (initargs nil)
942 (allocation nil)
943 (allocation-class nil)
944 (type t)
945 (namep nil)
946 (initp nil)
947 (allocp nil))
948
949 (dolist (slotd direct-slotds)
950 (when slotd
951 (unless namep
952 (setq name (slot-definition-name slotd)
953 namep t))
954 (unless initp
955 (when (slot-definition-initfunction slotd)
956 (setq initform (slot-definition-initform slotd)
957 initfunction (slot-definition-initfunction slotd)
958 initp t)))
959 (unless allocp
960 (setq allocation (slot-definition-allocation slotd)
961 allocation-class (slot-definition-class slotd)
962 allocp t))
963 (setq initargs (append (slot-definition-initargs slotd) initargs))
964 (let ((slotd-type (slot-definition-type slotd)))
965 (setq type (cond ((eq type t) slotd-type)
966 ((*subtypep type slotd-type) type)
967 (t `(and ,type ,slotd-type)))))))
968 (list :name name
969 :initform initform
970 :initfunction initfunction
971 :initargs initargs
972 :allocation allocation
973 :allocation-class allocation-class
974 :type type
975 :class class)))
976
977 (defmethod compute-effective-slot-definition-initargs :around
978 ((class structure-class) direct-slotds)
979 (let ((slotd (car direct-slotds)))
980 (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
981 :internal-reader-function (slot-definition-internal-reader-function slotd)
982 :internal-writer-function (slot-definition-internal-writer-function slotd)
983 (call-next-method))))
984
985 ;;;
986 ;;; NOTE: For bootstrapping considerations, these can't use make-instance
987 ;;; to make the method object. They have to use make-a-method which
988 ;;; is a specially bootstrapped mechanism for making standard methods.
989 ;;;
990 (defmethod reader-method-class ((class slot-class) direct-slot &rest initargs)
991 (declare (ignore direct-slot initargs))
992 (find-class 'standard-reader-method))
993
994 (defmethod add-reader-method ((class slot-class) generic-function slot-name)
995 (add-method generic-function
996 (make-a-method 'standard-reader-method
997 ()
998 (list (or (class-name class) 'object))
999 (list class)
1000 (make-reader-method-function class slot-name)
1001 "automatically generated reader method"
1002 slot-name)))
1003
1004 (defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
1005 (declare (ignore direct-slot initargs))
1006 (find-class 'standard-writer-method))
1007
1008 (defmethod add-writer-method ((class slot-class) generic-function slot-name)
1009 (add-method generic-function
1010 (make-a-method 'standard-writer-method
1011 ()
1012 (list 'new-value (or (class-name class) 'object))
1013 (list *the-class-t* class)
1014 (make-writer-method-function class slot-name)
1015 "automatically generated writer method"
1016 slot-name)))
1017
1018 (defmethod add-boundp-method ((class slot-class) generic-function slot-name)
1019 (add-method generic-function
1020 (make-a-method 'standard-boundp-method
1021 ()
1022 (list (or (class-name class) 'object))
1023 (list class)
1024 (make-boundp-method-function class slot-name)
1025 "automatically generated boundp method"
1026 slot-name)))
1027
1028 (defmethod remove-reader-method ((class slot-class) generic-function)
1029 (let ((method (get-method generic-function () (list class) nil)))
1030 (when method (remove-method generic-function method))))
1031
1032 (defmethod remove-writer-method ((class slot-class) generic-function)
1033 (let ((method
1034 (get-method generic-function () (list *the-class-t* class) nil)))
1035 (when method (remove-method generic-function method))))
1036
1037 (defmethod remove-boundp-method ((class slot-class) generic-function)
1038 (let ((method (get-method generic-function () (list class) nil)))
1039 (when method (remove-method generic-function method))))
1040
1041
1042 ;;;
1043 ;;; make-reader-method-function and make-write-method function are NOT part of
1044 ;;; the standard protocol. They are however useful, PCL makes uses makes use
1045 ;;; of them internally and documents them for PCL users.
1046 ;;;
1047 ;;; *** This needs work to make type testing by the writer functions which
1048 ;;; *** do type testing faster. The idea would be to have one constructor
1049 ;;; *** for each possible type test. In order to do this it would be nice
1050 ;;; *** to have help from inform-type-system-about-class and friends.
1051 ;;;
1052 ;;; *** There is a subtle bug here which is going to have to be fixed.
1053 ;;; *** Namely, the simplistic use of the template has to be fixed. We
1054 ;;; *** have to give the optimize-slot-value method the user might have
1055 ;;; *** defined for this metclass a chance to run.
1056 ;;;
1057 (defmethod make-reader-method-function ((class slot-class) slot-name)
1058 (make-std-reader-method-function (class-name class) slot-name))
1059
1060 (defmethod make-writer-method-function ((class slot-class) slot-name)
1061 (make-std-writer-method-function (class-name class) slot-name))
1062
1063 (defmethod make-boundp-method-function ((class slot-class) slot-name)
1064 (make-std-boundp-method-function (class-name class) slot-name))
1065
1066
1067 ;;;; inform-type-system-about-class
1068 ;;;
1069 ;;; This is NOT part of the standard protocol. It is an internal mechanism
1070 ;;; which PCL uses to *try* and tell the type system about class definitions.
1071 ;;; In a more fully integrated implementation of CLOS, the type system would
1072 ;;; know about class objects and class names in a more fundamental way and
1073 ;;; the mechanism used to inform the type system about new classes would be
1074 ;;; different.
1075 ;;;
1076 (defmethod inform-type-system-about-class ((class std-class) name)
1077 ;; Maybe add skeleton lisp:standard-class to avoid undefined-function
1078 ;; compiler warnings. Not otherwise needed in this implementation.
1079 (inform-type-system-about-std-class name))
1080
1081 (defmethod inform-type-system-about-class
1082 ((class funcallable-standard-class) name)
1083 (declare (ignore name))
1084 ;; Avoid load-time warning of changing metaclass.
1085 )
1086
1087
1088
1089 (defmethod compatible-meta-class-change-p (class proto-new-class)
1090 (eq (class-of class) (class-of proto-new-class)))
1091
1092 (defmethod validate-superclass ((class class) (new-super class))
1093 (or (eq new-super *the-class-t*)
1094 (eq (class-of class) (class-of new-super))))
1095
1096 (defmethod validate-superclass ((class standard-class) (new-super std-class))
1097 (let ((new-super-meta-class (class-of new-super)))
1098 (or (eq new-super-meta-class *the-class-std-class*)
1099 (eq (class-of class) new-super-meta-class))))
1100
1101
1102 ;;;
1103 ;;; Force the flushing of caches by creating a new wrapper for CLASS,
1104 ;;; if necessary.
1105 ;;;
1106 ;;; If the LAYOUT-INVALID slot of CLASS's wrapper is
1107 ;;;
1108 ;;; -- (:FLUSH <new wrapper>) or (:OBSOLETE <new wrapper>), there's
1109 ;;; nothing to do. The new wrapper has already been created.
1110 ;;;
1111 ;;; -- :INVALID, then it has been set to that value by a previous
1112 ;;; call to REGISTER-LAYOUT for a superclass S of CLASS; S's
1113 ;;; wrapper has been invalidated together with its subclasses. In
1114 ;;; this case, CLASS's caches must obviously be flushed, too, like
1115 ;;; S's. So, make a new wrapper for CLASS, and translate kernel's
1116 ;;; :INVALID to PCL (:FLUSH <new wrapper>). UPDATE-SLOTS can later
1117 ;;; decide if it wants to make this (:OBSOLETE ...).
1118 ;;;
1119 ;;; -- NIL, then the wrapper is still valid, in which case we do
1120 ;;; the same as for :INVALID, but for the obviously slightly
1121 ;;; different reason.
1122 ;;;
1123 (defun force-cache-flushes (class)
1124 (let* ((owrapper (class-wrapper class)))
1125 ;;
1126 ;; We only need to do something if the wrapper is still valid. If the
1127 ;; wrapper isn't valid, state will be FLUSH or OBSOLETE, and both of those
1128 ;; will already be doing what we want. In particular, we must be
1129 ;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE
1130 ;; means do what FLUSH does and then some.
1131 ;;
1132 (when (or (not (invalid-wrapper-p owrapper))
1133 (eq :invalid (kernel:layout-invalid owrapper)))
1134 (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
1135 class)))
1136 (setf (wrapper-instance-slots-layout nwrapper)
1137 (wrapper-instance-slots-layout owrapper))
1138 (setf (wrapper-class-slots nwrapper)
1139 (wrapper-class-slots owrapper))
1140 (with-pcl-lock
1141 (update-lisp-class-layout class nwrapper)
1142 (setf (slot-value class 'wrapper) nwrapper)
1143 (invalidate-wrapper owrapper :flush nwrapper))))))
1144
1145 (defun flush-cache-trap (owrapper nwrapper instance)
1146 (declare (ignore owrapper))
1147 (set-wrapper instance nwrapper))
1148
1149
1150
1151 ;;;
1152 ;;; make-instances-obsolete can be called by user code. It will cause the
1153 ;;; next access to the instance (as defined in 88-002R) to trap through the
1154 ;;; update-instance-for-redefined-class mechanism.
1155 ;;;
1156 (defmethod make-instances-obsolete ((class std-class))
1157 (let* ((owrapper (class-wrapper class))
1158 (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
1159 class)))
1160 (setf (wrapper-instance-slots-layout nwrapper)
1161 (wrapper-instance-slots-layout owrapper))
1162 (setf (wrapper-class-slots nwrapper)
1163 (wrapper-class-slots owrapper))
1164 (with-pcl-lock
1165 (update-lisp-class-layout class nwrapper)
1166 (setf (slot-value class 'wrapper) nwrapper)
1167 (invalidate-wrapper owrapper :obsolete nwrapper)
1168 class)))
1169
1170 (defmethod make-instances-obsolete ((class symbol))
1171 (make-instances-obsolete (find-class class)))
1172
1173
1174 ;;;
1175 ;;; obsolete-instance-trap is the internal trap that is called when we see
1176 ;;; an obsolete instance. The times when it is called are:
1177 ;;; - when the instance is involved in method lookup
1178 ;;; - when attempting to access a slot of an instance
1179 ;;;
1180 ;;; It is not called by class-of, wrapper-of, or any of the low-level instance
1181 ;;; access macros.
1182 ;;;
1183 ;;; Of course these times when it is called are an internal implementation
1184 ;;; detail of PCL and are not part of the documented description of when the
1185 ;;; obsolete instance update happens. The documented description is as it
1186 ;;; appears in 88-002R.
1187 ;;;
1188 ;;; This has to return the new wrapper, so it counts on all the methods on
1189 ;;; obsolete-instance-trap-internal to return the new wrapper. It also does
1190 ;;; a little internal error checking to make sure that the traps are only
1191 ;;; happening when they should, and that the trap methods are computing
1192 ;;; apropriate new wrappers.
1193 ;;;
1194
1195 ;;; obsolete-instance-trap might be called on structure instances
1196 ;;; after a structure is redefined. In most cases, obsolete-instance-trap
1197 ;;; will not be able to fix the old instance, so it must signal an
1198 ;;; error. The hard part of this is that the error system and debugger
1199 ;;; might cause obsolete-instance-trap to be called again, so in that
1200 ;;; case, we have to return some reasonable wrapper, instead.
1201
1202 (defvar *in-obsolete-instance-trap* nil)
1203 (defvar *the-wrapper-of-structure-object*
1204 (class-wrapper (find-class 'structure-object)))
1205
1206 (define-condition obsolete-structure (error)
1207 ((datum :reader obsolete-structure-datum :initarg :datum))
1208 (:report
1209 (lambda (condition stream)
1210 ;; Don't try to print the structure, since it probably
1211 ;; won't work.
1212 (format stream "Obsolete structure error in ~S:~@
1213 For a structure of type: ~S"
1214 (conditions::condition-function-name condition)
1215 (type-of (obsolete-structure-datum condition))))))
1216
1217 (defun obsolete-instance-trap (owrapper nwrapper instance)
1218 (if (not (pcl-instance-p instance))
1219 (if *in-obsolete-instance-trap*
1220 *the-wrapper-of-structure-object*
1221 (let ((*in-obsolete-instance-trap* t))
1222 (error 'obsolete-structure :datum instance)))
1223 (let* ((class (wrapper-class* nwrapper))
1224 (copy (allocate-instance class)) ;??? allocate-instance ???
1225 (olayout (wrapper-instance-slots-layout owrapper))
1226 (nlayout (wrapper-instance-slots-layout nwrapper))
1227 (oslots (get-slots instance))
1228 (nslots (get-slots copy))
1229 (oclass-slots (wrapper-class-slots owrapper))
1230 (added ())
1231 (discarded ())
1232 (plist ()))
1233 ;; local --> local transfer
1234 ;; local --> shared discard
1235 ;; local --> -- discard
1236 ;; shared --> local transfer
1237 ;; shared --> shared discard
1238 ;; shared --> -- discard
1239 ;; -- --> local add
1240 ;; -- --> shared --
1241 ;;
1242 ;; Go through all the old local slots.
1243 ;;
1244 (loop for name in olayout and opos from 0
1245 as npos = (posq name nlayout)
1246 if npos do
1247 (setf (instance-ref nslots npos)
1248 (instance-ref oslots opos))
1249 else do
1250 (push name discarded)
1251 (unless (eq (instance-ref oslots opos) +slot-unbound+)
1252 (setf (getf plist name)
1253 (instance-ref oslots opos))))
1254 ;;
1255 ;; Go through all the old shared slots.
1256 ;;
1257 (loop for (name . val) in oclass-slots
1258 for npos = (posq name nlayout)
1259 if npos do
1260 (setf (instance-ref nslots npos) val)
1261 else do
1262 (push name discarded)
1263 (unless (eq val +slot-unbound+)
1264 (setf (getf plist name) val)))
1265 ;;
1266 ;; Go through all the new local slots to compute the added slots.
1267 ;;
1268 (dolist (nlocal nlayout)
1269 (unless (or (memq nlocal olayout)
1270 (assq nlocal oclass-slots))
1271 (push nlocal added)))
1272
1273 (swap-wrappers-and-slots instance copy)
1274
1275 (update-instance-for-redefined-class instance
1276 added
1277 discarded
1278 plist)
1279 nwrapper)))
1280
1281
1282 ;;;
1283 ;;;
1284 ;;;
1285 (defmacro copy-instance-internal (instance)
1286 `(progn
1287 (let* ((class (class-of instance))
1288 (copy (allocate-instance class)))
1289 (if (std-instance-p ,instance)
1290 (setf (std-instance-slots ,instance) (std-instance-slots ,instance))
1291 (setf (fsc-instance-slots ,instance) (fsc-instance-slots ,instance)))
1292 copy)))
1293
1294 (defun change-class-internal (instance new-class initargs)
1295 (let* ((old-class (class-of instance))
1296 (copy (allocate-instance new-class))
1297 (new-wrapper (get-wrapper copy))
1298 (old-wrapper (class-wrapper old-class))
1299 (old-layout (wrapper-instance-slots-layout old-wrapper))
1300 (new-layout (wrapper-instance-slots-layout new-wrapper))
1301 (old-slots (get-slots instance))
1302 (new-slots (get-slots copy))
1303 (old-class-slots (wrapper-class-slots old-wrapper)))
1304
1305 ;;
1306 ;; "The values of local slots specified by both the class Cto and
1307 ;; Cfrom are retained. If such a local slot was unbound, it remains
1308 ;; unbound."
1309 ;;
1310 (loop for new-slot in new-layout and new-position from 0
1311 for old-position = (posq new-slot old-layout)
1312 when old-position do
1313 (setf (instance-ref new-slots new-position)
1314 (instance-ref old-slots old-position)))
1315 ;;
1316 ;; "The values of slots specified as shared in the class Cfrom and
1317 ;; as local in the class Cto are retained."
1318 ;;
1319 (loop for (name . val) in old-class-slots
1320 for new-position = (posq name new-layout)
1321 when new-position do
1322 (setf (instance-ref new-slots new-position) val))
1323
1324 ;; Make the copy point to the old instance's storage, and make the
1325 ;; old instance point to the new storage.
1326 (swap-wrappers-and-slots instance copy)
1327
1328 (apply #'update-instance-for-different-class copy instance initargs)
1329 instance))
1330
1331 (defmethod change-class ((instance standard-object)
1332 (new-class standard-class)
1333 &rest initargs)
1334 (change-class-internal instance new-class initargs))
1335
1336 (defmethod change-class ((instance funcallable-standard-object)
1337 (new-class funcallable-standard-class)
1338 &rest initargs)
1339 (change-class-internal instance new-class initargs))
1340
1341 (defmethod change-class ((instance standard-object)
1342 (new-class funcallable-standard-class)
1343 &rest initargs)
1344 (declare (ignore initargs))
1345 (error "Can't change the class of ~S to ~S~@
1346 because it isn't already an instance with metaclass ~S."
1347 instance new-class 'standard-class))
1348
1349 (defmethod change-class ((instance funcallable-standard-object)
1350 (new-class standard-class)
1351 &rest initargs)
1352 (declare (ignore initargs))
1353 (error "Can't change the class of ~S to ~S~@
1354 because it isn't already an instance with metaclass ~S."
1355 instance new-class 'funcallable-standard-class))
1356
1357 (defmethod change-class ((instance t) (new-class-name symbol) &rest initargs)
1358 (apply #'change-class instance (find-class new-class-name) initargs))
1359
1360
1361
1362 ;;;
1363 ;;; The metaclass BUILT-IN-CLASS
1364 ;;;
1365 ;;; This metaclass is something of a weird creature. By this point, all
1366 ;;; instances of it which will exist have been created, and no instance
1367 ;;; is ever created by calling MAKE-INSTANCE.
1368 ;;;
1369 ;;; But, there are other parts of the protcol we must follow and those
1370 ;;; definitions appear here.
1371 ;;;
1372 (defmethod shared-initialize :before
1373 ((class built-in-class) slot-names &rest initargs)
1374 (declare (ignore slot-names initargs))
1375 (error "Attempt to initialize or reinitialize a built in class."))
1376
1377 (defmethod class-direct-slots ((class built-in-class)) ())
1378 (defmethod class-slots ((class built-in-class)) ())
1379 (defmethod class-direct-default-initargs ((class built-in-class)) ())
1380 (defmethod class-default-initargs ((class built-in-class)) ())
1381
1382 (defmethod validate-superclass ((c class) (s built-in-class))
1383 (or (eq s *the-class-t*) (eq s *the-class-stream*)))
1384
1385
1386
1387 ;;;
1388 ;;;
1389 ;;;
1390
1391 (defmethod validate-superclass ((c slot-class)
1392 (f forward-referenced-class))
1393 t)
1394
1395
1396 ;;;
1397 ;;;
1398 ;;;
1399
1400 (defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
1401 (pushnew dependent (plist-value metaobject 'dependents)))
1402
1403 (defmethod remove-dependent ((metaobject dependent-update-mixin) dependent)
1404 (setf (plist-value metaobject 'dependents)
1405 (delete dependent (plist-value metaobject 'dependents))))
1406
1407 (defmethod map-dependents ((metaobject dependent-update-mixin) function)
1408 (dolist (dependent (plist-value metaobject 'dependents))
1409 (funcall function dependent)))
1410

  ViewVC Help
Powered by ViewVC 1.1.5