/[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.21 - (show annotations)
Tue Jan 12 17:51:09 1999 UTC (15 years, 3 months ago) by pw
Branch: MAIN
Changes since 1.20: +1 -5 lines
Modifies EXPAND-DEFCLASS to substitute pcl::standard-class for
lisp:standard-class in the superclass list given to defclass. This
is consistent with the treatment given the :metaclass option argument.

std-class.lisp is restored to its original state wiping out all traces
of bogus change introduced in revision 1.19.
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 #+cmu
28 (ext:file-comment
29 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/std-class.lisp,v 1.21 1999/01/12 17:51:09 pw 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 #+kcl (si:turbo-closure function)
103 (setf (slot-accessor-std-p slotd type) std-p)
104 (setf (slot-accessor-function slotd type) function))
105 (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all))))
106 (push (cons class name) *pv-table-cache-update-info*))))
107
108 (defmethod slot-definition-allocation ((slotd structure-slot-definition))
109 :instance)
110
111
112
113 (defmethod shared-initialize :after ((object documentation-mixin)
114 slot-names
115 &key (documentation nil documentation-p))
116 (declare (ignore slot-names))
117 (when documentation-p
118 (setf (plist-value object 'documentation) documentation)))
119
120 (defmethod documentation (object doc-type)
121 (declare (ignore object doc-type))
122 nil)
123
124 (defmethod (setf documentation) (new-value object doc-type)
125 (declare (ignore new-value doc-type))
126 (error "Can't change the documentation of ~S." object))
127
128 (defmethod documentation ((object documentation-mixin) doc-type)
129 (declare (ignore doc-type))
130 (plist-value object 'documentation))
131
132 (defmethod (setf documentation) (new-value (object documentation-mixin) doc-type)
133 (declare (ignore doc-type))
134 (setf (plist-value object 'documentation) new-value))
135
136
137 (defmethod documentation ((slotd standard-slot-definition) doc-type)
138 (declare (ignore doc-type))
139 (slot-value slotd 'documentation))
140
141 (defmethod (setf documentation) (new-value (slotd standard-slot-definition) doc-type)
142 (declare (ignore doc-type))
143 (setf (slot-value slotd 'documentation) new-value))
144
145
146 ;;;
147 ;;; Various class accessors that are a little more complicated than can be
148 ;;; done with automatically generated reader methods.
149 ;;;
150 (defmethod class-finalized-p ((class pcl-class))
151 (with-slots (wrapper) class
152 (not (null wrapper))))
153
154 (defmethod class-prototype ((class std-class))
155 (with-slots (prototype) class
156 (or prototype (setq prototype (allocate-instance class)))))
157
158 (defmethod class-prototype ((class structure-class))
159 (with-slots (prototype wrapper defstruct-constructor) class
160 (or prototype
161 (setq prototype
162 (if #-new-kcl-wrapper defstruct-constructor #+new-kcl-wrapper nil
163 (allocate-instance class)
164 (allocate-standard-instance wrapper))))))
165
166 (defmethod class-direct-default-initargs ((class slot-class))
167 (plist-value class 'direct-default-initargs))
168
169 (defmethod class-default-initargs ((class slot-class))
170 (plist-value class 'default-initargs))
171
172 (defmethod class-constructors ((class slot-class))
173 (plist-value class 'constructors))
174
175 (defmethod class-slot-cells ((class std-class))
176 (plist-value class 'class-slot-cells))
177
178
179 ;;;
180 ;;; Class accessors that are even a little bit more complicated than those
181 ;;; above. These have a protocol for updating them, we must implement that
182 ;;; protocol.
183 ;;;
184
185 ;;;
186 ;;; Maintaining the direct subclasses backpointers. The update methods are
187 ;;; here, the values are read by an automatically generated reader method.
188 ;;;
189 (defmethod add-direct-subclass ((class class) (subclass class))
190 (with-slots (direct-subclasses) class
191 (pushnew subclass direct-subclasses)
192 subclass))
193
194 (defmethod remove-direct-subclass ((class class) (subclass class))
195 (with-slots (direct-subclasses) class
196 (setq direct-subclasses (remove subclass direct-subclasses))
197 subclass))
198
199 ;;;
200 ;;; Maintaining the direct-methods and direct-generic-functions backpointers.
201 ;;;
202 ;;; There are four generic functions involved, each has one method for the
203 ;;; class case and another method for the damned EQL specializers. All of
204 ;;; these are specified methods and appear in their specified place in the
205 ;;; class graph.
206 ;;;
207 ;;; ADD-DIRECT-METHOD
208 ;;; REMOVE-DIRECT-METHOD
209 ;;; SPECIALIZER-DIRECT-METHODS
210 ;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
211 ;;;
212 ;;; In each case, we maintain one value which is a cons. The car is the list
213 ;;; methods. The cdr is a list of the generic functions. The cdr is always
214 ;;; computed lazily.
215 ;;;
216
217 (defmethod add-direct-method ((specializer class) (method method))
218 (with-slots (direct-methods) specializer
219 (setf (car direct-methods) (adjoin method (car direct-methods)) ;PUSH
220 (cdr direct-methods) ()))
221 method)
222
223 (defmethod remove-direct-method ((specializer class) (method method))
224 (with-slots (direct-methods) specializer
225 (setf (car direct-methods) (remove method (car direct-methods))
226 (cdr direct-methods) ()))
227 method)
228
229 (defmethod specializer-direct-methods ((specializer class))
230 (with-slots (direct-methods) specializer
231 (car direct-methods)))
232
233 (defmethod specializer-direct-generic-functions ((specializer class))
234 (with-slots (direct-methods) specializer
235 (or (cdr direct-methods)
236 (setf (cdr direct-methods)
237 (gathering1 (collecting-once)
238 (dolist (m (car direct-methods))
239 (gather1 (method-generic-function m))))))))
240
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 (gathering1 (collecting-once)
287 (dolist (m (car entry))
288 (gather1 (method-generic-function m)))))))))
289
290 (defun map-specializers (function)
291 (map-all-classes #'(lambda (class)
292 (funcall function (class-eq-specializer class))
293 (funcall function class)))
294 (maphash #'(lambda (object methods)
295 (declare (ignore methods))
296 (intern-eql-specializer object))
297 *eql-specializer-methods*)
298 (maphash #'(lambda (object specl)
299 (declare (ignore object))
300 (funcall function specl))
301 *eql-specializer-table*)
302 nil)
303
304 (defun map-all-generic-functions (function)
305 (let ((all-generic-functions (make-hash-table :test 'eq)))
306 (map-specializers #'(lambda (specl)
307 (dolist (gf (specializer-direct-generic-functions specl))
308 (unless (gethash gf all-generic-functions)
309 (setf (gethash gf all-generic-functions) t)
310 (funcall function gf))))))
311 nil)
312
313 (defmethod shared-initialize :after ((specl class-eq-specializer) slot-names &key)
314 (declare (ignore slot-names))
315 (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
316
317 (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
318 (declare (ignore slot-names))
319 (setf (slot-value specl 'type) `(eql ,(specializer-object specl))))
320
321
322
323 (defun real-load-defclass (name metaclass-name supers slots other accessors)
324 (do-standard-defsetfs-for-defclass accessors) ;***
325 (let ((res (apply #'ensure-class name :metaclass metaclass-name
326 :direct-superclasses supers
327 :direct-slots slots
328 :definition-source `((defclass ,name)
329 ,(load-truename))
330 other)))
331 ;; Defclass of a class with a forward-referenced superclass does not
332 ;; have a wrapper. RES is the incomplete PCL class. The Lisp class
333 ;; does not yet exist. Maybe should return NIL in that case as RES
334 ;; is not useful to the user?
335 #+cmu17 (and (class-wrapper res)(kernel:layout-class (class-wrapper res)))
336 #-cmu17 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 (supplied-slots (getf initargs :direct-slots unsupplied))
370 (meta
371 (cond ((neq supplied-meta unsupplied)
372 (find-class supplied-meta))
373 ((or (null class)
374 (forward-referenced-class-p class))
375 *the-class-standard-class*)
376 (t
377 (class-of class)))))
378 (flet ((fix-super (s)
379 (cond ((classp s) s)
380 ((not (legal-class-name-p s))
381 (error "~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 (loop (unless (remf initargs :metaclass) (return)))
388 (loop (unless (remf initargs :direct-superclasses) (return)))
389 (loop (unless (remf initargs :direct-slots) (return)))
390 (values meta
391 (list* :direct-superclasses
392 (and (neq supplied-supers unsupplied)
393 (mapcar #'fix-super supplied-supers))
394 :direct-slots
395 (and (neq supplied-slots unsupplied) supplied-slots)
396 initargs)))))
397
398
399 ;;;
400 ;;;
401 ;;;
402 #|| ; since it doesn't do anything
403 (defmethod shared-initialize :before ((class std-class)
404 slot-names
405 &key direct-superclasses)
406 (declare (ignore slot-names))
407 ;; *** error checking
408 )
409 ||#
410
411 (defmethod shared-initialize :after
412 ((class std-class)
413 slot-names
414 &key (direct-superclasses nil direct-superclasses-p)
415 (direct-slots nil direct-slots-p)
416 (direct-default-initargs nil direct-default-initargs-p)
417 (predicate-name nil predicate-name-p))
418 (declare (ignore slot-names))
419 (cond (direct-superclasses-p
420 (setq direct-superclasses
421 (or direct-superclasses
422 (list (if (funcallable-standard-class-p class)
423 *the-class-funcallable-standard-object*
424 *the-class-standard-object*))))
425 (dolist (superclass direct-superclasses)
426 (unless (validate-superclass class superclass)
427 (error "The class ~S was specified as a~%
428 super-class of the class ~S;~%~
429 but the meta-classes ~S and~%~S are incompatible.~@
430 Define a method for ~S to avoid this error."
431 superclass class (class-of superclass) (class-of class)
432 'validate-superclass)))
433 (setf (slot-value class 'direct-superclasses) direct-superclasses))
434 (t
435 (setq direct-superclasses (slot-value class 'direct-superclasses))))
436 (setq direct-slots
437 (if direct-slots-p
438 (setf (slot-value class 'direct-slots)
439 (mapcar #'(lambda (pl) (make-direct-slotd class pl)) direct-slots))
440 (slot-value class 'direct-slots)))
441 (if direct-default-initargs-p
442 (setf (plist-value class 'direct-default-initargs) direct-default-initargs)
443 (setq direct-default-initargs (plist-value class 'direct-default-initargs)))
444 (setf (plist-value class 'class-slot-cells)
445 (gathering1 (collecting)
446 (dolist (dslotd direct-slots)
447 (when (eq (slot-definition-allocation dslotd) class)
448 (let ((initfunction (slot-definition-initfunction dslotd)))
449 (gather1 (cons (slot-definition-name dslotd)
450 (if initfunction
451 (funcall initfunction)
452 *slot-unbound*))))))))
453 (setq predicate-name (if predicate-name-p
454 (setf (slot-value class 'predicate-name)
455 (car predicate-name))
456 (or (slot-value class 'predicate-name)
457 (setf (slot-value class 'predicate-name)
458 (make-class-predicate-name (class-name class))))))
459 (add-direct-subclasses class direct-superclasses)
460 (update-class class nil)
461 (make-class-predicate class predicate-name)
462 (add-slot-accessors class direct-slots))
463
464 (defmethod shared-initialize :before ((class class) slot-names &key name)
465 (declare (ignore slot-names name))
466 (setf (slot-value class 'type) `(class ,class))
467 (setf (slot-value class 'class-eq-specializer)
468 (make-instance 'class-eq-specializer :class class)))
469
470 (defmethod reinitialize-instance :before ((class slot-class) &key)
471 (remove-direct-subclasses class (class-direct-superclasses class))
472 (remove-slot-accessors class (class-direct-slots class)))
473
474 (defmethod reinitialize-instance :after ((class slot-class)
475 &rest initargs
476 &key)
477 (map-dependents class
478 #'(lambda (dependent)
479 (apply #'update-dependent class dependent initargs))))
480
481 (defmethod shared-initialize :after
482 ((class structure-class)
483 slot-names
484 &key (direct-superclasses nil direct-superclasses-p)
485 (direct-slots nil direct-slots-p)
486 direct-default-initargs
487 (predicate-name nil predicate-name-p))
488 (declare (ignore slot-names direct-default-initargs))
489 (if direct-superclasses-p
490 (setf (slot-value class 'direct-superclasses)
491 (or direct-superclasses
492 (setq direct-superclasses
493 (and (not (eq (class-name class) 'structure-object))
494 (list *the-class-structure-object*)))))
495 (setq direct-superclasses (slot-value class 'direct-superclasses)))
496 (let* ((name (class-name class))
497 (from-defclass-p (slot-value class 'from-defclass-p))
498 (defstruct-p (or from-defclass-p (not (structure-type-p name)))))
499 (if direct-slots-p
500 (setf (slot-value class 'direct-slots)
501 (setq direct-slots
502 (mapcar #'(lambda (pl)
503 (when defstruct-p
504 (let* ((slot-name (getf pl :name))
505 (acc-name (format nil "~s structure class ~a"
506 name slot-name))
507 (accessor (intern acc-name)))
508 (setq pl (list* :defstruct-accessor-symbol accessor
509 pl))))
510 (make-direct-slotd class pl))
511 direct-slots)))
512 (setq direct-slots (slot-value class 'direct-slots)))
513 (when defstruct-p
514 (let* ((include (car (slot-value class 'direct-superclasses)))
515 (conc-name (intern (format nil "~s structure class " name)))
516 (constructor (intern (format nil "~a constructor" conc-name)))
517 (defstruct `(defstruct (,name
518 ,@(when include
519 `((:include ,(class-name include))))
520 (:print-function print-std-instance)
521 (:predicate nil)
522 (:conc-name ,conc-name)
523 (:constructor ,constructor ()))
524 ,@(mapcar #'(lambda (slot)
525 `(,(slot-definition-name slot)
526 *slot-unbound*))
527 direct-slots)))
528 (reader-names (mapcar #'(lambda (slotd)
529 (intern (format nil "~A~A reader" conc-name
530 (slot-definition-name slotd))))
531 direct-slots))
532 (writer-names (mapcar #'(lambda (slotd)
533 (intern (format nil "~A~A writer" conc-name
534 (slot-definition-name slotd))))
535 direct-slots))
536 (readers-init
537 (mapcar #'(lambda (slotd reader-name)
538 (let ((accessor
539 (slot-definition-defstruct-accessor-symbol slotd)))
540 `(defun ,reader-name (obj)
541 (declare (type ,name obj))
542 (,accessor obj))))
543 direct-slots reader-names))
544 (writers-init
545 (mapcar #'(lambda (slotd writer-name)
546 (let ((accessor
547 (slot-definition-defstruct-accessor-symbol slotd)))
548 `(defun ,writer-name (nv obj)
549 (declare (type ,name obj))
550 (setf (,accessor obj) nv))))
551 direct-slots writer-names))
552 (defstruct-form
553 `(progn
554 ,defstruct
555 ,@readers-init ,@writers-init
556 (declare-structure ',name nil nil))))
557 (unless (structure-type-p name) (eval defstruct-form))
558 (mapc #'(lambda (dslotd reader-name writer-name)
559 (let* ((reader (gdefinition reader-name))
560 (writer (when (gboundp writer-name)
561 (gdefinition writer-name))))
562 (setf (slot-value dslotd 'internal-reader-function) reader)
563 (setf (slot-value dslotd 'internal-writer-function) writer)))
564 direct-slots reader-names writer-names)
565 (setf (slot-value class 'defstruct-form) defstruct-form)
566 (setf (slot-value class 'defstruct-constructor) constructor))))
567 (add-direct-subclasses class direct-superclasses)
568 (setf (slot-value class 'class-precedence-list)
569 (compute-class-precedence-list class))
570 (setf (slot-value class 'slots) (compute-slots class))
571 #-(or cmu17 new-kcl-wrapper)
572 (unless (slot-value class 'wrapper)
573 (setf (slot-value class 'wrapper) (make-wrapper 0 class)))
574 #+cmu17
575 (let ((lclass (lisp:find-class (class-name class))))
576 (setf (kernel:class-pcl-class lclass) class)
577 (setf (slot-value class 'wrapper) (kernel:class-layout lclass)))
578 #+new-kcl-wrapper
579 (let ((wrapper (get (class-name class) 'si::s-data)))
580 (setf (slot-value class 'wrapper) wrapper)
581 (setf (wrapper-class wrapper) class))
582 (update-pv-table-cache-info class)
583 (setq predicate-name (if predicate-name-p
584 (setf (slot-value class 'predicate-name)
585 (car predicate-name))
586 (or (slot-value class 'predicate-name)
587 (setf (slot-value class 'predicate-name)
588 (make-class-predicate-name (class-name class))))))
589 (make-class-predicate class predicate-name)
590 (add-slot-accessors class direct-slots))
591
592 (defmethod direct-slot-definition-class ((class structure-class) initargs)
593 (declare (ignore initargs))
594 (find-class 'structure-direct-slot-definition))
595
596 (defmethod finalize-inheritance ((class structure-class))
597 nil) ; always finalized
598
599 (defun add-slot-accessors (class dslotds)
600 (fix-slot-accessors class dslotds 'add))
601
602 (defun remove-slot-accessors (class dslotds)
603 (fix-slot-accessors class dslotds 'remove))
604
605 (defun fix-slot-accessors (class dslotds add/remove)
606 (flet ((fix (gfspec name r/w)
607 (let ((gf (ensure-generic-function gfspec)))
608 (case r/w
609 (r (if (eq add/remove 'add)
610 (add-reader-method class gf name)
611 (remove-reader-method class gf)))
612 (w (if (eq add/remove 'add)
613 (add-writer-method class gf name)
614 (remove-writer-method class gf)))))))
615 (dolist (dslotd dslotds)
616 (let ((slot-name (slot-definition-name dslotd)))
617 (dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r))
618 (dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w))))))
619
620
621 (defun add-direct-subclasses (class new)
622 (dolist (n new)
623 (unless (memq class (class-direct-subclasses class))
624 (add-direct-subclass n class))))
625
626 (defun remove-direct-subclasses (class new)
627 (let ((old (class-direct-superclasses class)))
628 (dolist (o (set-difference old new))
629 (remove-direct-subclass o class))))
630
631
632 ;;;
633 ;;;
634 ;;;
635 (defmethod finalize-inheritance ((class std-class))
636 (update-class class t))
637
638
639 (defun class-has-a-forward-referenced-superclass-p (class)
640 (or (forward-referenced-class-p class)
641 (some #'class-has-a-forward-referenced-superclass-p
642 (class-direct-superclasses class))))
643
644 ;;;
645 ;;; Called by :after shared-initialize whenever a class is initialized or
646 ;;; reinitialized. The class may or may not be finalized.
647 ;;;
648 (defun update-class (class finalizep)
649 (when (or finalizep (class-finalized-p class)
650 (not (class-has-a-forward-referenced-superclass-p class)))
651 (update-cpl class (compute-class-precedence-list class))
652 (update-slots class (compute-slots class))
653 (update-gfs-of-class class)
654 (update-inits class (compute-default-initargs class))
655 (update-make-instance-function-table class))
656 (unless finalizep
657 (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))
658
659 (defun update-cpl (class cpl)
660 (if (class-finalized-p class)
661 (unless (equal (class-precedence-list class) cpl)
662 ;; Need to have the cpl setup before update-lisp-class-layout
663 ;; is called on CMUCL.
664 (setf (slot-value class 'class-precedence-list) cpl)
665 (force-cache-flushes class))
666 (setf (slot-value class 'class-precedence-list) cpl))
667 (update-class-can-precede-p cpl))
668
669 (defun update-class-can-precede-p (cpl)
670 (when cpl
671 (let ((first (car cpl)))
672 (dolist (c (cdr cpl))
673 (pushnew c (slot-value first 'can-precede-list))))
674 (update-class-can-precede-p (cdr cpl))))
675
676 (defun class-can-precede-p (class1 class2)
677 (member class2 (class-can-precede-list class1)))
678
679 (defun update-slots (class eslotds)
680 (let ((instance-slots ())
681 (class-slots ()))
682 (dolist (eslotd eslotds)
683 (let ((alloc (slot-definition-allocation eslotd)))
684 (cond ((eq alloc :instance) (push eslotd instance-slots))
685 ((classp alloc) (push eslotd class-slots)))))
686 ;;
687 ;; If there is a change in the shape of the instances then the
688 ;; old class is now obsolete.
689 ;;
690 (let* ((nlayout (mapcar #'slot-definition-name
691 (sort instance-slots #'< :key #'slot-definition-location)))
692 (nslots (length nlayout))
693 (nwrapper-class-slots (compute-class-slots class-slots))
694 (owrapper (class-wrapper class))
695 (olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
696 (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
697 (nwrapper
698 (cond ((null owrapper)
699 (make-wrapper nslots class))
700 ((and (equal nlayout olayout)
701 (not
702 (iterate ((o (list-elements owrapper-class-slots))
703 (n (list-elements nwrapper-class-slots)))
704 (unless (eq (car o) (car n)) (return t)))))
705 owrapper)
706 (t
707 ;;
708 ;; This will initialize the new wrapper to have the same
709 ;; state as the old wrapper. We will then have to change
710 ;; that. This may seem like wasted work (it is), but the
711 ;; spec requires that we call make-instances-obsolete.
712 ;;
713 (make-instances-obsolete class)
714 (class-wrapper class)))))
715
716 (with-slots (wrapper slots) class
717 #+new-kcl-wrapper
718 (setf (si::s-data-name nwrapper) (class-name class))
719 #+cmu17
720 (update-lisp-class-layout class nwrapper)
721 (setf slots eslotds
722 (wrapper-instance-slots-layout nwrapper) nlayout
723 (wrapper-class-slots nwrapper) nwrapper-class-slots
724 (wrapper-no-of-instance-slots nwrapper) nslots
725 wrapper nwrapper))
726
727 (unless (eq owrapper nwrapper)
728 (update-pv-table-cache-info class)))))
729
730 (defun compute-class-slots (eslotds)
731 (gathering1 (collecting)
732 (dolist (eslotd eslotds)
733 (gather1
734 (assoc (slot-definition-name eslotd)
735 (class-slot-cells (slot-definition-allocation eslotd)))))))
736
737 (defun compute-layout (cpl instance-eslotds)
738 (let* ((names
739 (gathering1 (collecting)
740 (dolist (eslotd instance-eslotds)
741 (when (eq (slot-definition-allocation eslotd) :instance)
742 (gather1 (slot-definition-name eslotd))))))
743 (order ()))
744 (labels ((rwalk (tail)
745 (when tail
746 (rwalk (cdr tail))
747 (dolist (ss (class-slots (car tail)))
748 (let ((n (slot-definition-name ss)))
749 (when (member n names)
750 (setq order (cons n order)
751 names (remove n names))))))))
752 (rwalk (if (slot-boundp (car cpl) 'slots)
753 cpl
754 (cdr cpl)))
755 (reverse (append names order)))))
756
757 (defun update-gfs-of-class (class)
758 (when (and (class-finalized-p class)
759 (let ((cpl (class-precedence-list class)))
760 (or (member *the-class-slot-class* cpl)
761 (member *the-class-standard-effective-slot-definition* cpl))))
762 (let ((gf-table (make-hash-table :test 'eq)))
763 (labels ((collect-gfs (class)
764 (dolist (gf (specializer-direct-generic-functions class))
765 (setf (gethash gf gf-table) t))
766 (mapc #'collect-gfs (class-direct-superclasses class))))
767 (collect-gfs class)
768 (maphash #'(lambda (gf ignore)
769 (declare (ignore ignore))
770 (update-gf-dfun class gf))
771 gf-table)))))
772
773 (defun update-inits (class inits)
774 (setf (plist-value class 'default-initargs) inits))
775
776
777 ;;;
778 ;;;
779 ;;;
780 (defmethod compute-default-initargs ((class slot-class))
781 (let ((cpl (class-precedence-list class))
782 (direct (class-direct-default-initargs class)))
783 (labels ((walk (tail)
784 (if (null tail)
785 nil
786 (let ((c (pop tail)))
787 (append (if (eq c class)
788 direct
789 (class-direct-default-initargs c))
790 (walk tail))))))
791 (let ((initargs (walk cpl)))
792 (delete-duplicates initargs :test #'eq :key #'car :from-end t)))))
793
794
795 ;;;
796 ;;; Protocols for constructing direct and effective slot definitions.
797 ;;;
798 ;;;
799 ;;;
800 ;;;
801 (defmethod direct-slot-definition-class ((class std-class) initargs)
802 (declare (ignore initargs))
803 (find-class 'standard-direct-slot-definition))
804
805 (defun make-direct-slotd (class initargs)
806 (let ((initargs (list* :class class initargs)))
807 (apply #'make-instance (direct-slot-definition-class class initargs) initargs)))
808
809 ;;;
810 ;;;
811 ;;;
812 (defmethod compute-slots ((class std-class))
813 ;;
814 ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
815 ;; for each different slot name we find in our superclasses. Each
816 ;; call receives the class and a list of the dslotds with that name.
817 ;; The list is in most-specific-first order.
818 ;;
819 (let ((name-dslotds-alist ()))
820 (dolist (c (class-precedence-list class))
821 (let ((dslotds (class-direct-slots c)))
822 (dolist (d dslotds)
823 (let* ((name (slot-definition-name d))
824 (entry (assq name name-dslotds-alist)))
825 (if entry
826 (push d (cdr entry))
827 (push (list name d) name-dslotds-alist))))))
828 (mapcar #'(lambda (direct)
829 (compute-effective-slot-definition class
830 (nreverse (cdr direct))))
831 name-dslotds-alist)))
832
833 (defmethod compute-slots :around ((class std-class))
834 (let ((eslotds (call-next-method))
835 (cpl (class-precedence-list class))
836 (instance-slots ())
837 (class-slots ()))
838 (dolist (eslotd eslotds)
839 (let ((alloc (slot-definition-allocation eslotd)))
840 (cond ((eq alloc :instance) (push eslotd instance-slots))
841 ((classp alloc) (push eslotd class-slots)))))
842 (let ((nlayout (compute-layout cpl instance-slots)))
843 (dolist (eslotd instance-slots)
844 (setf (slot-definition-location eslotd)
845 (position (slot-definition-name eslotd) nlayout))))
846 (dolist (eslotd class-slots)
847 (setf (slot-definition-location eslotd)
848 (assoc (slot-definition-name eslotd)
849 (class-slot-cells (slot-definition-allocation eslotd)))))
850 (mapc #'initialize-internal-slot-functions eslotds)
851 eslotds))
852
853 (defmethod compute-slots ((class structure-class))
854 (mapcan #'(lambda (superclass)
855 (mapcar #'(lambda (dslotd)
856 (compute-effective-slot-definition class
857 (list dslotd)))
858 (class-direct-slots superclass)))
859 (reverse (slot-value class 'class-precedence-list))))
860
861 (defmethod compute-slots :around ((class structure-class))
862 (let ((eslotds (call-next-method)))
863 (mapc #'initialize-internal-slot-functions eslotds)
864 eslotds))
865
866 (defmethod compute-effective-slot-definition ((class slot-class) dslotds)
867 (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
868 (class (effective-slot-definition-class class initargs)))
869 (apply #'make-instance class initargs)))
870
871 (defmethod effective-slot-definition-class ((class std-class) initargs)
872 (declare (ignore initargs))
873 (find-class 'standard-effective-slot-definition))
874
875 (defmethod effective-slot-definition-class ((class structure-class) initargs)
876 (declare (ignore initargs))
877 (find-class 'structure-effective-slot-definition))
878
879 (defmethod compute-effective-slot-definition-initargs
880 ((class slot-class) direct-slotds)
881 (let* ((name nil)
882 (initfunction nil)
883 (initform nil)
884 (initargs nil)
885 (allocation nil)
886 (type t)
887 (namep nil)
888 (initp nil)
889 (allocp nil))
890
891 (dolist (slotd direct-slotds)
892 (when slotd
893 (unless namep
894 (setq name (slot-definition-name slotd)
895 namep t))
896 (unless initp
897 (when (slot-definition-initfunction slotd)
898 (setq initform (slot-definition-initform slotd)
899 initfunction (slot-definition-initfunction slotd)
900 initp t)))
901 (unless allocp
902 (setq allocation (slot-definition-allocation slotd)
903 allocp t))
904 (setq initargs (append (slot-definition-initargs slotd) initargs))
905 (let ((slotd-type (slot-definition-type slotd)))
906 (setq type (cond ((eq type 't) slotd-type)
907 ((*subtypep type slotd-type) type)
908 (t `(and ,type ,slotd-type)))))))
909 (list :name name
910 :initform initform
911 :initfunction initfunction
912 :initargs initargs
913 :allocation allocation
914 :type type
915 :class class)))
916
917 (defmethod compute-effective-slot-definition-initargs :around
918 ((class structure-class) direct-slotds)
919 (let ((slotd (car direct-slotds)))
920 (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
921 :internal-reader-function (slot-definition-internal-reader-function slotd)
922 :internal-writer-function (slot-definition-internal-writer-function slotd)
923 (call-next-method))))
924
925 ;;;
926 ;;; NOTE: For bootstrapping considerations, these can't use make-instance
927 ;;; to make the method object. They have to use make-a-method which
928 ;;; is a specially bootstrapped mechanism for making standard methods.
929 ;;;
930 (defmethod reader-method-class ((class slot-class) direct-slot &rest initargs)
931 (declare (ignore direct-slot initargs))
932 (find-class 'standard-reader-method))
933
934 (defmethod add-reader-method ((class slot-class) generic-function slot-name)
935 (add-method generic-function
936 (make-a-method 'standard-reader-method
937 ()
938 (list (or (class-name class) 'object))
939 (list class)
940 (make-reader-method-function class slot-name)
941 "automatically generated reader method"
942 slot-name)))
943
944 (defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
945 (declare (ignore direct-slot initargs))
946 (find-class 'standard-writer-method))
947
948 (defmethod add-writer-method ((class slot-class) generic-function slot-name)
949 (add-method generic-function
950 (make-a-method 'standard-writer-method
951 ()
952 (list 'new-value (or (class-name class) 'object))
953 (list *the-class-t* class)
954 (make-writer-method-function class slot-name)
955 "automatically generated writer method"
956 slot-name)))
957
958 (defmethod add-boundp-method ((class slot-class) generic-function slot-name)
959 (add-method generic-function
960 (make-a-method 'standard-boundp-method
961 ()
962 (list (or (class-name class) 'object))
963 (list class)
964 (make-boundp-method-function class slot-name)
965 "automatically generated boundp method"
966 slot-name)))
967
968 (defmethod remove-reader-method ((class slot-class) generic-function)
969 (let ((method (get-method generic-function () (list class) nil)))
970 (when method (remove-method generic-function method))))
971
972 (defmethod remove-writer-method ((class slot-class) generic-function)
973 (let ((method
974 (get-method generic-function () (list *the-class-t* class) nil)))
975 (when method (remove-method generic-function method))))
976
977 (defmethod remove-boundp-method ((class slot-class) generic-function)
978 (let ((method (get-method generic-function () (list class) nil)))
979 (when method (remove-method generic-function method))))
980
981
982 ;;;
983 ;;; make-reader-method-function and make-write-method function are NOT part of
984 ;;; the standard protocol. They are however useful, PCL makes uses makes use
985 ;;; of them internally and documents them for PCL users.
986 ;;;
987 ;;; *** This needs work to make type testing by the writer functions which
988 ;;; *** do type testing faster. The idea would be to have one constructor
989 ;;; *** for each possible type test. In order to do this it would be nice
990 ;;; *** to have help from inform-type-system-about-class and friends.
991 ;;;
992 ;;; *** There is a subtle bug here which is going to have to be fixed.
993 ;;; *** Namely, the simplistic use of the template has to be fixed. We
994 ;;; *** have to give the optimize-slot-value method the user might have
995 ;;; *** defined for this metclass a chance to run.
996 ;;;
997 (defmethod make-reader-method-function ((class slot-class) slot-name)
998 (make-std-reader-method-function (class-name class) slot-name))
999
1000 (defmethod make-writer-method-function ((class slot-class) slot-name)
1001 (make-std-writer-method-function (class-name class) slot-name))
1002
1003 (defmethod make-boundp-method-function ((class slot-class) slot-name)
1004 (make-std-boundp-method-function (class-name class) slot-name))
1005
1006
1007 ;;;; inform-type-system-about-class
1008 ;;;; make-type-predicate
1009 ;;;
1010 ;;; These are NOT part of the standard protocol. They are internal mechanism
1011 ;;; which PCL uses to *try* and tell the type system about class definitions.
1012 ;;; In a more fully integrated implementation of CLOS, the type system would
1013 ;;; know about class objects and class names in a more fundamental way and
1014 ;;; the mechanism used to inform the type system about new classes would be
1015 ;;; different.
1016 ;;;
1017 (defmethod inform-type-system-about-class ((class std-class) name)
1018 (inform-type-system-about-std-class name))
1019
1020
1021 (defmethod compatible-meta-class-change-p (class proto-new-class)
1022 (eq (class-of class) (class-of proto-new-class)))
1023
1024 (defmethod validate-superclass ((class class) (new-super class))
1025 (or (eq new-super *the-class-t*)
1026 (eq (class-of class) (class-of new-super))))
1027
1028 (defmethod validate-superclass ((class standard-class) (new-super std-class))
1029 (let ((new-super-meta-class (class-of new-super)))
1030 (or (eq new-super-meta-class *the-class-std-class*)
1031 (eq (class-of class) new-super-meta-class))))
1032
1033
1034 ;;;
1035 ;;;
1036 ;;;
1037 (defun force-cache-flushes (class)
1038 (let* ((owrapper (class-wrapper class))
1039 (state (wrapper-state owrapper)))
1040 ;;
1041 ;; We only need to do something if the state is still T. If the
1042 ;; state isn't T, it will be FLUSH or OBSOLETE, and both of those
1043 ;; will already be doing what we want. In particular, we must be
1044 ;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE
1045 ;; means do what FLUSH does and then some.
1046 ;;
1047 (when (eq state 't)
1048 (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
1049 class)))
1050 (setf (wrapper-instance-slots-layout nwrapper)
1051 (wrapper-instance-slots-layout owrapper))
1052 (setf (wrapper-class-slots nwrapper)
1053 (wrapper-class-slots owrapper))
1054 (without-interrupts
1055 #+cmu17
1056 (update-lisp-class-layout class nwrapper)
1057 (setf (slot-value class 'wrapper) nwrapper)
1058 (invalidate-wrapper owrapper ':flush nwrapper))))))
1059
1060 (defun flush-cache-trap (owrapper nwrapper instance)
1061 (declare (ignore owrapper))
1062 (set-wrapper instance nwrapper))
1063
1064
1065
1066 ;;;
1067 ;;; make-instances-obsolete can be called by user code. It will cause the
1068 ;;; next access to the instance (as defined in 88-002R) to trap through the
1069 ;;; update-instance-for-redefined-class mechanism.
1070 ;;;
1071 (defmethod make-instances-obsolete ((class std-class))
1072 (let* ((owrapper (class-wrapper class))
1073 (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
1074 class)))
1075 (setf (wrapper-instance-slots-layout nwrapper)
1076 (wrapper-instance-slots-layout owrapper))
1077 (setf (wrapper-class-slots nwrapper)
1078 (wrapper-class-slots owrapper))
1079 (without-interrupts
1080 #+cmu17
1081 (update-lisp-class-layout class nwrapper)
1082 (setf (slot-value class 'wrapper) nwrapper)
1083 (invalidate-wrapper owrapper ':obsolete nwrapper)
1084 class)))
1085
1086 (defmethod make-instances-obsolete ((class symbol))
1087 (make-instances-obsolete (find-class class)))
1088
1089
1090 ;;;
1091 ;;; obsolete-instance-trap is the internal trap that is called when we see
1092 ;;; an obsolete instance. The times when it is called are:
1093 ;;; - when the instance is involved in method lookup
1094 ;;; - when attempting to access a slot of an instance
1095 ;;;
1096 ;;; It is not called by class-of, wrapper-of, or any of the low-level instance
1097 ;;; access macros.
1098 ;;;
1099 ;;; Of course these times when it is called are an internal implementation
1100 ;;; detail of PCL and are not part of the documented description of when the
1101 ;;; obsolete instance update happens. The documented description is as it
1102 ;;; appears in 88-002R.
1103 ;;;
1104 ;;; This has to return the new wrapper, so it counts on all the methods on
1105 ;;; obsolete-instance-trap-internal to return the new wrapper. It also does
1106 ;;; a little internal error checking to make sure that the traps are only
1107 ;;; happening when they should, and that the trap methods are computing
1108 ;;; apropriate new wrappers.
1109 ;;;
1110
1111 ;;; obsolete-instance-trap might be called on structure instances
1112 ;;; after a structure is redefined. In most cases, obsolete-instance-trap
1113 ;;; will not be able to fix the old instance, so it must signal an
1114 ;;; error. The hard part of this is that the error system and debugger
1115 ;;; might cause obsolete-instance-trap to be called again, so in that
1116 ;;; case, we have to return some reasonable wrapper, instead.
1117
1118 (defvar *in-obsolete-instance-trap* nil)
1119 (defvar *the-wrapper-of-structure-object*
1120 (class-wrapper (find-class 'structure-object)))
1121
1122 #+cmu17
1123 (define-condition obsolete-structure (error)
1124 ((datum :reader obsolete-structure-datum :initarg :datum))
1125 (:report
1126 (lambda (condition stream)
1127 ;; Don't try to print the structure, since it probably
1128 ;; won't work.
1129 (format stream "Obsolete structure error in ~S:~@
1130 For a structure of type: ~S"
1131 (conditions::condition-function-name condition)
1132 (type-of (obsolete-structure-datum condition))))))
1133
1134 (defun obsolete-instance-trap (owrapper nwrapper instance)
1135 (if (not #-(or cmu17 new-kcl-wrapper)
1136 (or (std-instance-p instance) (fsc-instance-p instance))
1137 #+cmu17
1138 (pcl-instance-p instance)
1139 #+new-kcl-wrapper
1140 nil)
1141 (if *in-obsolete-instance-trap*
1142 *the-wrapper-of-structure-object*
1143 (let ((*in-obsolete-instance-trap* t))
1144 #-cmu17
1145 (error "The structure ~S is obsolete." instance)
1146 #+cmu17
1147 (error 'obsolete-structure :datum instance)))
1148 (let* ((class (wrapper-class* nwrapper))
1149 (copy (allocate-instance class)) ;??? allocate-instance ???
1150 (olayout (wrapper-instance-slots-layout owrapper))
1151 (nlayout (wrapper-instance-slots-layout nwrapper))
1152 (oslots (get-slots instance))
1153 (nslots (get-slots copy))
1154 (oclass-slots (wrapper-class-slots owrapper))
1155 (added ())
1156 (discarded ())
1157 (plist ()))
1158 ;; local --> local transfer
1159 ;; local --> shared discard
1160 ;; local --> -- discard
1161 ;; shared --> local transfer
1162 ;; shared --> shared discard
1163 ;; shared --> -- discard
1164 ;; -- --> local add
1165 ;; -- --> shared --
1166 ;;
1167 ;; Go through all the old local slots.
1168 ;;
1169 (iterate ((name (list-elements olayout))
1170 (opos (interval :from 0)))
1171 (let ((npos (posq name nlayout)))
1172 (if npos
1173 (setf (instance-ref nslots npos) (instance-ref oslots opos))
1174 (progn
1175 (push name discarded)
1176 (unless (eq (instance-ref oslots opos) *slot-unbound*)
1177 (setf (getf plist name) (instance-ref oslots opos)))))))
1178 ;;
1179 ;; Go through all the old shared slots.
1180 ;;
1181 (iterate ((oclass-slot-and-val (list-elements oclass-slots)))
1182 (let ((name (car oclass-slot-and-val))
1183 (val (cdr oclass-slot-and-val)))
1184 (let ((npos (posq name nlayout)))
1185 (if npos
1186 (setf (instance-ref nslots npos) (cdr oclass-slot-and-val))
1187 (progn (push name discarded)
1188 (unless (eq val *slot-unbound*)
1189 (setf (getf plist name) val)))))))
1190 ;;
1191 ;; Go through all the new local slots to compute the added slots.
1192 ;;
1193 (dolist (nlocal nlayout)
1194 (unless (or (memq nlocal olayout)
1195 (assq nlocal oclass-slots))
1196 (push nlocal added)))
1197
1198 (swap-wrappers-and-slots instance copy)
1199
1200 (update-instance-for-redefined-class instance
1201 added
1202 discarded
1203 plist)
1204 nwrapper)))
1205
1206
1207 ;;;
1208 ;;;
1209 ;;;
1210 (defmacro copy-instance-internal (instance)
1211 `(#+new-kcl-wrapper if #-new-kcl-wrapper progn
1212 #+new-kcl-wrapper (not (std-instance-p ,instance))
1213 (let* ((class (class-of instance))
1214 (copy (allocate-instance class)))
1215 (if (std-instance-p ,instance)
1216 (setf (std-instance-slots ,instance) (std-instance-slots ,instance))
1217 (setf (fsc-instance-slots ,instance) (fsc-instance-slots ,instance)))
1218 copy)
1219 #+new-kcl-wrapper
1220 (copy-structure-header ,instance)))
1221
1222 (defun change-class-internal (instance new-class)
1223 (let* ((old-class (class-of instance))
1224 (copy (allocate-instance new-class))
1225 (new-wrapper (get-wrapper copy))
1226 (old-wrapper (class-wrapper old-class))
1227 (old-layout (wrapper-instance-slots-layout old-wrapper))
1228 (new-layout (wrapper-instance-slots-layout new-wrapper))
1229 (old-slots (get-slots instance))
1230 (new-slots (get-slots copy))
1231 (old-class-slots (wrapper-class-slots old-wrapper)))
1232
1233 ;;
1234 ;; "The values of local slots specified by both the class Cto and
1235 ;; Cfrom are retained. If such a local slot was unbound, it remains
1236 ;; unbound."
1237 ;;
1238 (iterate ((new-slot (list-elements new-layout))
1239 (new-position (interval :from 0)))
1240 (let ((old-position (posq new-slot old-layout)))
1241 (when old-position
1242 (setf (instance-ref new-slots new-position)
1243 (instance-ref old-slots old-position)))))
1244
1245 ;;
1246 ;; "The values of slots specified as shared in the class Cfrom and
1247 ;; as local in the class Cto are retained."
1248 ;;
1249 (iterate ((slot-and-val (list-elements old-class-slots)))
1250 (let ((position (posq (car slot-and-val) new-layout)))
1251 (when position
1252 (setf (instance-ref new-slots position) (cdr slot-and-val)))))
1253
1254 ;; Make the copy point to the old instance's storage, and make the
1255 ;; old instance point to the new storage.
1256 (swap-wrappers-and-slots instance copy)
1257
1258 (update-instance-for-different-class copy instance)
1259 instance))
1260
1261 (defmethod change-class ((instance standard-object)
1262 (new-class standard-class))
1263 (change-class-internal instance new-class))
1264
1265 (defmethod change-class ((instance funcallable-standard-object)
1266 (new-class funcallable-standard-class))
1267 (change-class-internal instance new-class))
1268
1269 (defmethod change-class ((instance standard-object)
1270 (new-class funcallable-standard-class))
1271 (error "Can't change the class of ~S to ~S~@
1272 because it isn't already an instance with metaclass ~S."
1273 instance new-class 'standard-class))
1274
1275 (defmethod change-class ((instance funcallable-standard-object)
1276 (new-class standard-class))
1277 (error "Can't change the class of ~S to ~S~@
1278 because it isn't already an instance with metaclass ~S."
1279 instance new-class 'funcallable-standard-class))
1280
1281 (defmethod change-class ((instance t) (new-class-name symbol))
1282 (change-class instance (find-class new-class-name)))
1283
1284
1285
1286 ;;;
1287 ;;; The metaclass BUILT-IN-CLASS
1288 ;;;
1289 ;;; This metaclass is something of a weird creature. By this point, all
1290 ;;; instances of it which will exist have been created, and no instance
1291 ;;; is ever created by calling MAKE-INSTANCE.
1292 ;;;
1293 ;;; But, there are other parts of the protcol we must follow and those
1294 ;;; definitions appear here.
1295 ;;;
1296 (defmethod shared-initialize :before
1297 ((class built-in-class) slot-names &rest initargs)
1298 (declare (ignore slot-names initargs))
1299 (error "Attempt to initialize or reinitialize a built in class."))
1300
1301 (defmethod class-direct-slots ((class built-in-class)) ())
1302 (defmethod class-slots ((class built-in-class)) ())
1303 (defmethod class-direct-default-initargs ((class built-in-class)) ())
1304 (defmethod class-default-initargs ((class built-in-class)) ())
1305
1306 (defmethod validate-superclass ((c class) (s built-in-class))
1307 (or (eq s *the-class-t*) #+cmu (eq s *the-class-stream*)))
1308
1309
1310
1311 ;;;
1312 ;;;
1313 ;;;
1314
1315 (defmethod validate-superclass ((c slot-class)
1316 (f forward-referenced-class))
1317 't)
1318
1319
1320 ;;;
1321 ;;;
1322 ;;;
1323
1324 (defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
1325 (pushnew dependent (plist-value metaobject 'dependents)))
1326
1327 (defmethod remove-dependent ((metaobject dependent-update-mixin) dependent)
1328 (setf (plist-value metaobject 'dependents)
1329 (delete dependent (plist-value metaobject 'dependents))))
1330
1331 (defmethod map-dependents ((metaobject dependent-update-mixin) function)
1332 (dolist (dependent (plist-value metaobject 'dependents))
1333 (funcall function dependent)))
1334

  ViewVC Help
Powered by ViewVC 1.1.5